ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: ndwarshuis:master
Branches Tags
ndwarshuis:master
ndwarshuis:add_tx_amount_sign_column
ndwarshuis:fix_cache
ndwarshuis:use_subaccount
ndwarshuis:add_budget_limits
ndwarshuis:update_dhall_types
..
compare: ndwarshuis:add_budget_limits
Branches Tags
ndwarshuis:add_tx_amount_sign_column
ndwarshuis:master
ndwarshuis:fix_cache
ndwarshuis:use_subaccount
ndwarshuis:add_budget_limits
ndwarshuis:update_dhall_types

No commits in common. "master" and "add_budget_limits" have entirely different histories.
master ... add_budget

12 changed files with 1686 additions and 2912 deletions
Show Stats Expand all files Collapse all files

118
app/Main.hs
View File

@ -2,21 +2,21 @@
module Main (main) where
import Control.Concurrent
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Data.Bitraversable
-- import Data.Hashable
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import qualified Database.Esqueleto.Experimental as E
import qualified Dhall hiding (double, record)
import Database.Persist.Monad
import Dhall hiding (double, record)
import Internal.Budget
import Internal.Database
import Internal.History
import Internal.Types.Main
import Internal.Utils
import Options.Applicative
import RIO
import RIO.FilePath
-- import qualified RIO.Map as M
import qualified RIO.Text as T
main :: IO ()
@ -30,26 +30,14 @@ main = parse =<< execParser o
<> header "pwncash - your budget, your life"
)
type ConfigPath = FilePath
type BudgetPath = FilePath
type HistoryPath = FilePath
data Options = Options !ConfigPath !Mode
data Options = Options FilePath Mode
data Mode
= Reset
| DumpCurrencies
| DumpAccounts
| DumpAccountKeys
| Sync !SyncOptions
data SyncOptions = SyncOptions
{ syncBudgets :: ![BudgetPath]
, syncHistories :: ![HistoryPath]
, syncThreads :: !Int
}
| Sync
configFile :: Parser FilePath
configFile =
@ -67,7 +55,7 @@ options =
<|> getConf dumpCurrencies
<|> getConf dumpAccounts
<|> getConf dumpAccountKeys
<|> getConf sync_
<|> getConf sync
where
getConf m = Options <$> configFile <*> m
@ -108,43 +96,14 @@ dumpAccountKeys =
<> help "Dump all account keys/aliases"
)
sync_ :: Parser Mode
sync_ =
sync :: Parser Mode
sync =
flag'
Sync
( long "sync"
<> short 'S'
<> help "Sync config to database"
)
<*> syncOptions
syncOptions :: Parser SyncOptions
syncOptions =
SyncOptions
<$> many
( strOption
( long "budget"
<> short 'b'
<> metavar "BUDGET"
<> help "path to a budget config"
)
)
<*> many
( strOption
( long "history"
<> short 'H'
<> metavar "HISTORY"
<> help "path to a history config"
)
)
<*> option
auto
( long "threads"
<> short 't'
<> metavar "THREADS"
<> value 1
<> help "number of threads for syncing"
)
parse :: Options -> IO ()
parse (Options c Reset) = do
@ -153,8 +112,7 @@ parse (Options c Reset) = do
parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c
parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
runSync syncThreads c syncBudgets syncHistories
parse (Options c Sync) = runSync c
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
runDumpCurrencies c = do
@ -192,34 +150,50 @@ runDumpAccountKeys c = do
ar <- accounts <$> readConfig c
let ks =
paths2IDs $
fmap (double . accountRFullpath . E.entityVal) $
fst $
indexAcntRoot ar
fmap (double . fst) $
concatMap (t3 . uncurry tree2Records) $
flattenAcntRoot ar
mapM_ (uncurry printPair) ks
where
printPair i p = do
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
t3 (_, _, x) = x
double x = (x, x)
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
runSync threads c bs hs = do
setNumCapabilities threads
runSync :: FilePath -> IO ()
runSync c = do
config <- readConfig c
(bs', hs') <-
fmap (bimap concat concat . partitionEithers) $
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
(Left <$> bs) ++ (Right <$> hs)
let (hTs, hSs) = splitHistory $ statements config
pool <- runNoLoggingT $ mkPool $ sqlConfig config
setNumCapabilities 1
handle err $ sync pool root config bs' hs'
handle err $ do
-- _ <- askLoggerIO
-- get the current DB state
(state, updates) <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ getDBState config
-- read desired statements from disk
bSs <-
flip runReaderT state $
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
-- update the DB
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
let hTransRes = mapErrors insertHistTransfer hTs
let bgtRes = mapErrors insertBudget $ budget config
updateDBState updates -- TODO this will only work if foreign keys are deferred
res <- runExceptT $ do
mapM_ (uncurry insertHistStmt) bSs
combineError hTransRes bgtRes $ \_ _ -> ()
rerunnableIO $ fromEither res
where
root = takeDirectory c
err (AppException es) = do
err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure
readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig = fmap unfix . readDhall
-- showBalances
readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath
readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath

6
budget.cabal
View File

@ -75,8 +75,7 @@ library
ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
build-depends:
Decimal >=0.5.2
, base >=4.12 && <10
base >=4.12 && <10
, cassava
, conduit >=1.3.4.2
, containers >=0.6.4.1
@ -145,8 +144,7 @@ executable pwncash
ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
build-depends:
Decimal >=0.5.2
, base >=4.12 && <10
base >=4.12 && <10
, budget
, cassava
, conduit >=1.3.4.2

453
dhall/Types.dhall
View File

@ -278,52 +278,9 @@ let DatePat =
-}
< Cron : CronPat.Type | Mod : ModPat.Type >
let TxAmount1_ =
\(re : Type) ->
{ a1Column : Text
, a1Fmt :
{-
Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
re
}
let TxAmount1 =
{ Type = TxAmount1_ Text
, default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
}
let TxAmount2_ =
\(re : Type) ->
{ a2Positive : Text
, a2Negative : Text
, a2Fmt :
{-
Format of the amount field. Must include two fields for the
numerator and denominator of the amount.
-}
re
}
let TxAmount2 =
{ Type = TxAmount2_ Text
, default =
{ a2Positive = "Deposit"
, a2Negative = "Withdraw"
, a2Fmt = "([0-9\\.]+)"
}
}
let TxAmountSpec_ =
\(re : Type) ->
< AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
let TxOpts_ =
{-
Additional metadata to use when parsing a statement
-}
\(re : Type) ->
let TxOpts =
{- Additional metadata to use when parsing a statement -}
{ Type =
{ toDate :
{-
Column title for date
@ -333,7 +290,7 @@ let TxOpts_ =
{-
Column title for amount
-}
TxAmountSpec_ re
Text
, toDesc :
{-
Column title for description
@ -351,51 +308,19 @@ let TxOpts_ =
Data.Time.Format.formattime Haskell function.
-}
Text
, toSkipBlankDate :
{-
Skip line if date field is a blank
, toAmountFmt :
{- Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
Bool
, toSkipBlankAmount :
{-
Skip line if amount field(s) is(are) a blank
-}
Bool
, toSkipBlankDescription :
{-
Skip line if description field is a blank
-}
Bool
, toSkipBlankOther :
{-
Skip line if any arbitrary fields are blank (these fields must also
be listed in 'toOther' to be considered)
-}
List Text
, toSkipMissingFields :
{-
Skip line if any fields are missing (this is different from blank;
'missing' means there is no field with name 'X', 'blank' means that
there is a field 'X' and its value is an empty string)
-}
Bool
Text
}
let TxAmountSpec = TxAmountSpec_ Text
let TxOpts =
{ Type = TxOpts_ Text
, default =
{ toDate = "Date"
, toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
, toAmount = "Amount"
, toDesc = "Description"
, toOther = [] : List Text
, toDateFmt = "%0m/%0d/%Y"
, toSkipBlankDate = False
, toSkipBlankAmount = False
, toSkipBlankDescription = False
, toSkipBlankOther = [] : List Text
, toSkipMissingFields = False
, toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
}
}
@ -477,45 +402,9 @@ let EntryNumGetter =
LookupN: lookup the value from a field
ConstN: a constant value
AmountN: the value of the 'Amount' column times a scaling factor
BalanceN: the amount required to make the target account reach a balance
PercentN: the amount required to make an account reach a given percentage
AmountN: the value of the 'Amount' column
-}
< LookupN : Text
| ConstN : Double
| AmountN : Double
| BalanceN : Double
| PercentN : Double
>
let LinkedNumGetter =
{-
Means to get a numeric value from another entry
-}
{ Type =
{ lngIndex :
{-
Index of the entry to link.
-}
Natural
, lngScale :
{-
Factor by which to multiply the value of the linked entry.
-}
Double
}
, default = { lngScale = 1.0, lngIndex = 0 }
}
let LinkedEntryNumGetter =
{-
Means to get a numeric value from a statement row or another entry getter.
Linked: a number referring to the entry on the 'from' side of the
transaction (with 0 being the primary entry)
Getter: a normal getter
-}
< Linked : LinkedNumGetter.Type | Getter : EntryNumGetter >
< LookupN : Text | ConstN : Double | AmountN : Double >
let EntryTextGetter =
{-
@ -554,6 +443,7 @@ let Entry =
-}
\(a : Type) ->
\(v : Type) ->
\(c : Type) ->
\(t : Type) ->
{ eAcnt :
{-
@ -565,6 +455,11 @@ let Entry =
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)
@ -579,107 +474,35 @@ let Entry =
let EntryGetter =
{-
Means for getting an entry from a given row in a statement (debit side)
-}
\(n : Type) ->
{ Type = Entry EntryAcntGetter n TagID
, default = { eComment = "", eTags = [] : List TagID }
}
let FromEntryGetter =
{-
Means for getting an entry from a given row in a statement (debit side)
-}
EntryGetter EntryNumGetter
let ToEntryGetter =
{-
Means for getting an entry from a given row in a statement (credit side)
-}
EntryGetter LinkedEntryNumGetter
let TxHalfGetter =
{-
Means of transforming one row in a statement to either the credit or debit
half of a transaction
-}
\(e : Type) ->
{ Type =
{ thgAcnt :
{-
Account from which this transaction will be balanced. The value
of the transaction will be assigned to this account unless
other entries are specified (see below).
This account (and its associated entry) will be denoted
'primary'.
-}
EntryAcntGetter
, thgEntries :
{-
Means of getting additional entries from which this transaction
will be balanced. If this list is empty, the total value of the
transaction will be assigned to the value defined by 'tsgAcnt'.
Otherwise, the entries specified here will be added to this side
of this transaction, and their sum value will be subtracted from
the total value of the transaction and assigned to 'tsgAcnt'.
This is useful for situations where a particular transaction
denotes values that come from multiple subaccounts.
-}
List e
, thgComment :
{-
Comment for the primary entry
-}
Text
, thgTags :
{-
Tags for the primary entry
-}
List TagID
}
, default =
{ thgTags = [] : List TagID
, thgComment = ""
, thgEntries = [] : List e
}
}
let FromTxHalfGetter = TxHalfGetter FromEntryGetter.Type
let ToTxHalfGetter = TxHalfGetter ToEntryGetter.Type
let TxSubGetter =
{-
A means for transforming one row in a statement to a transaction
Means for getting an entry from a given row in a statement
-}
{ Type =
{ tsgValue : EntryNumGetter
, tsgCurrency : EntryCurGetter
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
}
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
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.
-}
{ Type =
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
, tgScale : Double
, tgCurrency : EntryCurGetter
, tgOtherEntries : List TxSubGetter.Type
}
, default =
{ tgOtherEntries = [] : List TxSubGetter.Type
, tgFrom = TxHalfGetter
, tgTo = TxHalfGetter
, tgScale = 1.0
}
{ 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_ =
@ -719,7 +542,7 @@ let StatementParser_ =
a transaction. If none, don't make a transaction (eg 'skip'
this row in the statement).
-}
Optional TxGetter.Type
Optional TxGetter
, spTimes :
{-
Match at most this many rows; if none there is no limit
@ -736,7 +559,7 @@ let StatementParser_ =
, spVal = ValMatcher::{=}
, spDesc = None Text
, spOther = [] : List (FieldMatcher_ re)
, spTx = None TxGetter.Type
, spTx = None TxGetter
, spTimes = None Natural
, spPriority = +0
}
@ -754,29 +577,7 @@ let Amount =
-}
\(w : Type) ->
\(v : Type) ->
{ Type =
{ amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
, default.amtPriority = +0
}
let TransferType =
{-
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
-}
< TPercent | TBalance | TFixed >
let TransferValue =
{-
Means to determine the value of a budget transfer.
-}
{ Type = { tvVal : Double, tvType : TransferType }
, default.tvType = TransferType.TFixed
}
{ amtWhen : w, amtValue : v, amtDesc : Text }
let Transfer =
{-
@ -789,24 +590,14 @@ let Transfer =
{ transFrom : a
, transTo : a
, transCurrency : c
, transAmounts : List (Amount w v).Type
}
let TaggedAcnt =
{-
An account with a tag
-}
{ Type = { taAcnt : AcntID, taTags : List TagID }
, default.taTags = [] : List TagID
, transAmounts : List (Amount w v)
}
let HistTransfer =
{-
A manually specified historical transfer
-}
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
let TransferAmount = Amount DatePat TransferValue.Type
Transfer AcntID CurID DatePat Double
let Statement =
{-
@ -843,6 +634,44 @@ let History =
-}
< 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
@ -850,7 +679,12 @@ let Allocation =
-}
\(w : Type) ->
\(v : Type) ->
{ alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type }
{ alloTo : TaggedAcnt
, alloAmts : List (Amount w v)
, alloCur :
{-TODO allow exchanges here-}
CurID
}
let PretaxValue =
{-
@ -945,8 +779,6 @@ let SingleAllocation =
-}
Allocation {}
let SingleAlloAmount = \(v : Type) -> Amount {} v
let MultiAllocation =
{-
An allocation specialized to capturing multiple income streams within a given
@ -955,8 +787,6 @@ let MultiAllocation =
-}
Allocation Interval
let MultiAlloAmount = \(v : Type) -> Amount Interval v
let HourlyPeriod =
{-
Definition for a pay period denominated in hours
@ -1039,40 +869,55 @@ let Income =
This must be an income AcntID, and is the only place income
accounts may be specified in the entire budget.
-}
TaggedAcnt.Type
TaggedAcnt
, incToBal :
{-
The account to which to send the remainder of the income stream
(if any) after all allocations have been applied.
-}
TaggedAcnt.Type
, incPriority : Integer
TaggedAcnt
}
, default =
{ incPretax = [] : List (SingleAllocation PretaxValue)
, incTaxes = [] : List (SingleAllocation TaxValue)
, incPosttaxx = [] : List (SingleAllocation PosttaxValue)
, incPriority = +0
}
}
let AcntMatcher_ =
let AcntSet =
{-
Regex pattern by which matching account ids will be identified
A list of account IDs represented as a set.
-}
\(re : Type) ->
{ Type = { amPat : re, amInvert : Bool }, default.amInvert = False }
{ 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 AcntMatcher = AcntMatcher_ Text
let TransferMatcher_ =
let TransferMatcher =
{-
Means to match a transfer (which will be used to "clone" it in some
fashion)
-}
\(re : Type) ->
{ tmFrom : Optional (AcntMatcher_ re).Type
, tmTo : Optional (AcntMatcher_ re).Type
{ 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.
@ -1084,17 +929,25 @@ let TransferMatcher_ =
-}
ValMatcher.Type
}
let TransferMatcher =
{ Type = TransferMatcher_ Text
, default =
{ tmFrom = None AcntMatcher.Type
, tmTo = None AcntMatcher.Type
{ 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 =
{-
A transaction analogous to another transfer with given properties.
@ -1103,17 +956,17 @@ let ShadowTransfer =
{-
Source of this transfer
-}
TaggedAcnt.Type
TaggedAcnt
, stTo :
{-
Destination of this transfer.
-}
TaggedAcnt.Type
TaggedAcnt
, stCurrency :
{-
Currency of this transfer.
-}
CurID
BudgetCurrency
, stDesc :
{-
Description of this transfer.
@ -1127,6 +980,7 @@ let ShadowTransfer =
specified in other fields of this type.
-}
TransferMatcher.Type
, stType : BudgetTransferType
, stRatio :
{-
Fixed multipler to translate value of matched transfer to this one.
@ -1134,11 +988,17 @@ let ShadowTransfer =
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
-}
HistTransfer
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
let Budget =
{-
@ -1180,7 +1040,6 @@ in { CurID
, CronPat
, DatePat
, TxOpts
, TxOpts_
, StatementParser
, StatementParser_
, ValMatcher
@ -1189,13 +1048,10 @@ in { CurID
, FieldMatcher
, FieldMatcher_
, EntryNumGetter
, LinkedEntryNumGetter
, LinkedNumGetter
, Field
, FieldMap
, Entry
, FromEntryGetter
, ToEntryGetter
, EntryGetter
, EntryTextGetter
, EntryCurGetter
, EntryAcntGetter
@ -1206,11 +1062,12 @@ in { CurID
, Budget
, Allocation
, Amount
, TransferMatcher_
, TransferMatcher
, ShadowTransfer
, AcntSet
, BudgetCurrency
, Exchange
, TaggedAcnt
, AccountTree
, Account
, Placeholder
, PretaxValue
@ -1219,29 +1076,13 @@ in { CurID
, TaxProgression
, TaxMethod
, TaxValue
, TransferValue
, TransferType
, BudgetTransferValue
, BudgetTransferType
, TxGetter
, TxSubGetter
, TxHalfGetter
, FromTxHalfGetter
, ToTxHalfGetter
, HistTransfer
, SingleAllocation
, MultiAllocation
, HourlyPeriod
, Period
, PeriodType
, TransferAmount
, MultiAlloAmount
, SingleAlloAmount
, AcntMatcher_
, AcntMatcher
, TxAmountSpec
, TxAmountSpec_
, TxAmount1_
, TxAmount2_
, TxAmount1
, TxAmount2
, BudgetTransfer
}

95
dhall/common.dhall
View File

@ -4,10 +4,18 @@ let List/map =
let T = ./Types.dhall
let nullEntry =
let nullSplit =
\(a : T.EntryAcntGetter) ->
\(v : T.EntryNumGetter) ->
T.FromEntryGetter::{ eAcnt = a, eValue = v }
\(c : T.EntryCurGetter) ->
T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
let nullOpts = T.TxOpts::{=}
let nullVal = T.ValMatcher::{=}
let nullMatch = T.StatementParser::{=}
let nullCron = T.CronPat::{=}
let nullMod =
\(by : Natural) ->
@ -19,22 +27,21 @@ let cron1 =
\(m : Natural) ->
\(d : Natural) ->
T.DatePat.Cron
T.CronPat::{
, cpYear = Some (T.MDYPat.Single y)
( nullCron
// { cpYear = Some (T.MDYPat.Single y)
, cpMonth = Some (T.MDYPat.Single m)
, cpDay = Some (T.MDYPat.Single d)
}
)
let matchInf_ = T.StatementParser::{=}
let matchInf_ = nullMatch
let matchInf = \(x : T.TxGetter.Type) -> T.StatementParser::{ spTx = Some x }
let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
let matchN_ = \(n : Natural) -> T.StatementParser::{ spTimes = Some n }
let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
let matchN =
\(n : Natural) ->
\(x : T.TxGetter.Type) ->
matchInf x // { spTimes = Some n }
\(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
let match1_ = matchN_ 1
@ -79,45 +86,46 @@ let mRngYMD =
\(r : Natural) ->
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
let partNFrom =
\(ss : List PartEntry) ->
let toEntry =
\(x : PartEntry) ->
T.FromEntryGetter::{
, eAcnt = T.EntryAcntGetter.ConstT x._1
, eValue = T.EntryNumGetter.ConstN x._2
let partN =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
\(comment : Text) ->
\(ss : List PartSplit) ->
let toSplit =
\(x : PartSplit) ->
nullSplit (T.EntryAcntGetter.ConstT x._1) c
// { eValue = Some (T.EntryNumGetter.ConstN x._2)
, eComment = x._3
}
in List/map PartEntry T.FromEntryGetter.Type toEntry ss
in [ nullSplit a c // { eComment = comment } ]
# List/map PartSplit T.EntryGetter.Type toSplit ss
let partNTo =
\(ss : List PartEntry) ->
let toEntry =
\(x : PartEntry) ->
T.ToEntryGetter::{
, eAcnt = T.EntryAcntGetter.ConstT x._1
, eValue =
T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
, eComment = x._3
}
let part1 =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
\(comment : Text) ->
partN c a comment ([] : List PartSplit)
in List/map PartEntry T.ToEntryGetter.Type toEntry ss
let part1_ =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
partN c a "" ([] : List PartSplit)
let addDay =
\(x : T.GregorianM) ->
\(d : Natural) ->
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
let mvP = T.ValMatcher::{ vmSign = Some True }
let mvP = nullVal // { vmSign = Some True }
let mvN = T.ValMatcher::{ vmSign = Some False }
let mvN = nullVal // { vmSign = Some False }
let mvNum = \(x : Natural) -> T.ValMatcher::{ vmNum = Some x }
let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
let mvDen = \(x : Natural) -> T.ValMatcher::{ vmDen = Some x }
let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
@ -127,7 +135,13 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
in { cron1
in { nullSplit
, nullMatch
, nullVal
, nullOpts
, nullCron
, nullMod
, cron1
, mY
, mYM
, mYMD
@ -142,8 +156,9 @@ in { cron1
, match1
, greg
, gregM
, partNFrom
, partNTo
, partN
, part1
, part1_
, addDay
, comma = 44
, tab = 9
@ -155,8 +170,6 @@ in { cron1
, mvDen
, mvDenP
, mvDenN
, PartEntry
, nullEntry
, nullMod
, PartSplit
}
/\ T

515
lib/Internal/Budget.hs
View File

@ -1,9 +1,9 @@
module Internal.Budget (readBudgetCRUD) where
module Internal.Budget (insertBudget) where
import Control.Monad.Except
import Data.Decimal hiding (allocate)
import Data.Foldable
import Data.Hashable
import Database.Persist.Monad
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -13,13 +13,22 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
readBudgetCRUD o@CRUDOps {coCreate} = do
bs <- mapM readBudget coCreate
return $ o {coCreate = bs}
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions
-- 5. insert all transactions
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
readBudget
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
-> m ()
insertBudget
b@Budget
{ bgtLabel
, bgtIncomes
@ -30,18 +39,15 @@ readBudget
, bgtPosttax
, bgtInterval
} =
do
spanRes <- getSpan
(bgtLabel,) <$> case spanRes of
Nothing -> return []
Just budgetSpan -> do
whenHash CTBudget b () $ \key -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers c budgetSpan bgtTransfers
combineErrorM (concat <$> res1) res2 $ \is ts ->
addShadowTransfers bgtShadowTransfers (is ++ ts)
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
where
c = CommitR (CommitHash $ hash b) CTBudget
acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,)
pre_ = sortAllos bgtPretax
@ -52,15 +58,73 @@ readBudget
(alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
getSpan = do
globalSpan <- asks (unBSpan . tsBudgetScope)
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do
localSpan <- liftExcept $ resolveDaySpan bi
return $ intersectDaySpan globalSpan localSpan
sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
where
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
let balTo = M.findWithDefault 0 ftTo bals
x = amtToMove balTo cvType cvValue
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
in (bals', f {ftValue = 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 _ BTFixed x = x
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
-- TODO this seems too general for this module
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
insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer
-> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k entry = do
sk <- insertEntry k entry
insert_ $ BudgetLabelR sk $ bmName ftMeta
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (EntryPair, Maybe EntryPair)
entryPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
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
let s1 = entry curid from_ (-v)
let s2 = entry curid to_ v
combineError s1 s2 (,)
entry c TaggedAcnt {taAcnt, taTags} v =
resolveEntry $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldSpan [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
@ -79,101 +143,100 @@ sortAllo a@Allocation {alloAmts = as} = do
-- 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 :(
readIncome
:: (MonadAppError m, MonadFinance m)
=> CommitR
insertIncome
:: (MonadInsertError m, MonadFinance m)
=> CommitRId
-> T.Text
-> IntAllocations
-> DaySpan
-> Maybe Interval
-> Income
-> m [Tx CommitR]
readIncome
-> m [UnbalancedTransfer]
insertIncome
key
name
(intPre, intTax, intPost)
ds
localInterval
Income
{ incWhen
, incCurrency
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
, incFrom
, incPretax
, incPosttax
, incTaxes
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
, incToBal
, incGross
, incPayPeriod
, incPriority
} =
combineErrorM
(combineError incRes nonIncRes (,))
(combineError cpRes dayRes (,))
$ \_ (cp, days) -> do
let gross = realFracToDecimalP (cpPrec cp) incGross
foldDays (allocate cp gross) start days
(combineError precRes dayRes (,))
$ \_ (precision, days) -> do
let gross = roundPrecision precision incGross
concat <$> foldDays (allocate precision gross) start days
where
srcAcnt' = AcntID srcAcnt
destAcnt' = AcntID destAcnt
incRes = isIncomeAcnt srcAcnt'
incRes = isIncomeAcnt $ taAcnt incFrom
nonIncRes =
mapErrors isNotIncomeAcnt $
destAcnt'
taAcnt incToBal
: (alloAcnt <$> incPretax)
++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax)
cpRes = lookupCurrency incCurrency
dayRes = liftExcept $ expandDatePat ds incWhen
precRes = lookupCurrencyPrec incCurrency
dayRes = askDays incWhen localInterval
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
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
allocate cp gross prevDay day = do
-- TODO ensure these are all the "correct" accounts
allocate precision gross prevDay day = do
scaler <- liftExcept $ periodScaler pType' prevDay day
let precision = cpPrec cp
let (preDeductions, pre) =
allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre
let tax =
tax =
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = gross - sumAllos (tax ++ pre)
let post =
post =
allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
let allos = allo2Trans <$> (pre ++ tax ++ post)
let primary =
EntrySet
{ esTotalValue = -gross
, esCurrency = cpID cp
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
}
return $
Tx
{ txMeta = TxMeta day incPriority (TxDesc "") key
, txPrimary = Left primary
, txOther = []
balance = aftertaxGross - sumAllos post
bal =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = incFrom
, ftCur = NoX incCurrency
, ftTo = incToBal
, ftValue = UnbalancedValue BTFixed balance
, ftDesc = "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))
periodScaler
:: PeriodType
-> Day
-> Day
-> AppExcept PeriodScaler
-> InsertExcept PeriodScaler
periodScaler pt prev cur = return scale
where
n = workingDays wds prev cur
n = fromIntegral $ workingDays wds prev cur
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
scale prec x = case pt of
scale precision x = case pt of
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
fromRational (rnd $ x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours
* fromIntegral n
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
* n
Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
-- ASSUME start < end
workingDays :: [Weekday] -> Day -> Day -> Natural
@ -189,7 +252,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
-- ASSUME days is a sorted list
foldDays
:: MonadAppError m
:: MonadInsertError m
=> (Day -> Day -> m a)
-> Day
-> [Day]
@ -199,27 +262,27 @@ foldDays f start days = case NE.nonEmpty days of
Just ds
| any (start >) ds ->
throwError $
AppException [PeriodError start $ minimum ds]
InsertException [PeriodError start $ minimum ds]
| otherwise ->
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt = checkAcntType IncomeT
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
checkAcntType
:: (MonadAppError m, MonadFinance m)
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
-> m ()
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadAppError m, MonadFinance m)
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m ()
@ -227,70 +290,83 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
where
go t
| t `L.elem` ts = return i
| otherwise = throwError $ AppException [AccountTypeError i ts]
| otherwise = throwError $ InsertException [AccountError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faTo = alloTo
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
-- ASSUME allocations are sorted
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloTo} =
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faTo = alloTo
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
Entry
{ eValue = LinkValue (EntryFixed faValue)
, eComment = faDesc
, eAcnt = AcntID taAcnt
, eTags = TagID <$> taTags
allo2Trans
:: BudgetMeta
-> Day
-> TaggedAcnt
-> FlatAllocation Rational
-> UnbalancedTransfer
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = from
, ftCur = faCur
, ftTo = faTo
, ftValue = UnbalancedValue BTFixed faValue
, ftDesc = faDesc
}
type PreDeductions = M.Map T.Text Decimal
allocatePre
:: Precision
-> Decimal
:: Natural
-> Rational
-> [FlatAllocation PretaxValue]
-> (PreDeductions, [FlatAllocation Decimal])
-> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre precision gross = L.mapAccumR go M.empty
where
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
let v =
if prePercent
then gross *. (preValue / 100)
else realFracToDecimalP precision preValue
in (mapAdd_ preCategory v m, f {faValue = v})
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})
allocateTax
:: Precision
-> Decimal
-> PreDeductions
:: Natural
-> Rational
-> M.Map T.Text Rational
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Decimal]
-> [FlatAllocation Rational]
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
TMPercent p -> agi *. p / 100
TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
let taxDed = f precision tpDeductible
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
-- | Compute effective tax percentage of a bracket
@ -304,102 +380,174 @@ allocateTax precision gross preDeds f = fmap (fmap go)
--
-- 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 -> Precision -> Decimal -> [TaxBracket] -> Decimal
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
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 = f prec tbLowerLimit
in if remain >= l
then (acc + (remain - l) *. (tbPercent / 100), l)
else a
let l = roundPrecision precision $ f precision tbLowerLimit
p = roundPrecision 3 tbPercent / 100
in if remain >= l then (acc + p * (remain - l), l) else a
allocatePost
:: Precision
-> Decimal
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Decimal]
allocatePost prec aftertax = fmap (fmap go)
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
where
go PosttaxValue {postValue, postPercent}
| postPercent = aftertax *. (postValue / 100)
| otherwise = realFracToDecimalP prec postValue
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
--------------------------------------------------------------------------------
-- Standalone Transfer
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> Maybe Interval
-> [BudgetTransfer]
-> m [UnbalancedTransfer]
expandTransfers key name localInterval ts = do
txs <-
fmap (L.sortOn ftWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
case localInterval of
Nothing -> return txs
Just i -> do
bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . ftWhen) txs
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
{ ftMeta = meta
, ftWhen = day
, ftCur = transCurrency
, ftFrom = transFrom
, ftTo = transTo
, ftValue = UnbalancedValue y $ roundPrecision precision v
, ftDesc = desc
}
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
--------------------------------------------------------------------------------
-- shadow transfers
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: (MonadAppError m, MonadFinance m)
=> [ShadowTransfer]
-> [Tx CommitR]
-> m [Tx CommitR]
addShadowTransfers ms = mapErrors go
where
go tx = do
es <- catMaybes <$> mapErrors (fromShadow tx) ms
return $ tx {txOther = Right <$> es}
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
fromShadow
:: (MonadAppError m, MonadFinance m)
=> Tx CommitR
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
-> m (Maybe ShadowEntrySet)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
combineErrorM curRes mRes $ \cur compiled -> do
res <- liftExcept $ shadowMatches compiled tx
let es = entryPair stFrom stTo cur stDesc stRatio ()
return $ if not res then Nothing else Just es
where
curRes = lookupCurrencyKey stCurrency
mRes = liftExcept $ compileMatch stMatch
shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
shadowMatches
TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
Tx {txPrimary, txMeta = TxMeta {txmDate}} =
do
-- ASSUME these will never fail and thus I don't need to worry about
-- stacking the errors
fromRes <- acntMatches fa tmFrom
toRes <- acntMatches ta tmTo
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
-> 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 $
fromRes
&& toRes
&& maybe True (`dateMatches` txmDate) tmDate
if not res
then Nothing
else
Just $
FlatTransfer
{ ftMeta = ftMeta tx
, ftWhen = ftWhen tx
, ftCur = stCurrency
, ftFrom = stFrom
, ftTo = stTo
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
, ftDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx
return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate
&& valRes
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
acntMatches (AcntID a) = maybe (return True) (match' a)
match' a AcntMatcher_ {amPat, amInvert} =
(if amInvert then not else id) <$> matchMaybe a amPat
compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
where
go a@AcntMatcher_ {amPat} = do
(_, p) <- compileRegex False amPat
return $ a {amPat = p}
tres = mapM go tmTo
fres = mapM go tmFrom
-- memberMaybe x AcntSet {asList, asInclude} =
-- (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
--------------------------------------------------------------------------------
-- random
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
alloAcnt :: Allocation w v -> AcntID
alloAcnt = AcntID . taAcnt . alloTo
alloAcnt = taAcnt . alloTo
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt
, ftValue :: !v
, ftWhen :: !Day
, ftDesc :: !T.Text
, ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency
}
deriving (Show)
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
type IntAllocations =
( [DaySpanAllocation PretaxValue]
@ -409,11 +557,14 @@ type IntAllocations =
type DaySpanAllocation = Allocation DaySpan
type PeriodScaler = Precision -> Double -> Decimal
type EntryPair = (KeyEntry, KeyEntry)
type PeriodScaler = Natural -> Double -> Double
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
deriving (Functor, Show)

1001
lib/Internal/Database.hs
View File

File diff suppressed because it is too large Load Diff

507
lib/Internal/History.hs
View File

@ -1,17 +1,15 @@
module Internal.History
( readHistStmt
, readHistTransfer
, splitHistory
, readHistoryCRUD
( splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
)
where
import Control.Monad.Except
import Data.Csv
import Data.Decimal
import Data.Foldable
import Data.Hashable
import GHC.Real
import Database.Persist.Monad
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -22,73 +20,107 @@ import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
readHistoryCRUD
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> PreHistoryCRUD
-> m FinalHistoryCRUD
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
-- TODO multithread this for some extra fun :)
ss' <- mapErrorsIO (readHistStmt root) ss
fromEitherM $ runExceptT $ do
let sRes = mapErrors (ExceptT . return) ss'
let tRes = mapErrors readHistTransfer ts
combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
-- NOTE keep statement and transfer readers separate because the former needs
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
-- thingy
splitHistory :: [History] -> ([PairedTransfer], [Statement])
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
--------------------------------------------------------------------------------
-- Transfers
readHistTransfer
:: (MonadAppError m, MonadFinance m)
=> PairedTransfer
-> m [Tx CommitR]
readHistTransfer ht = do
bounds <- asks (unHSpan . tsHistoryScope)
expandTransfer c bounds ht
where
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
--------------------------------------------------------------------------------
-- Statements
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)
=> FilePath
-> Statement
-> m (Either AppException [Tx CommitR])
readHistStmt root i = do
bounds <- asks (unHSpan . tsHistoryScope)
-> m (Maybe (CommitR, [KeyTx]))
readHistStmt root i = whenHash_ CTImport i $ do
bs <- readImport root i
return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
bounds <- askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where
go t@Tx {txMeta = m} =
t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txEntries = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txEntries = ss} =
fmap (\kss -> t {txEntries = kss}) $
combineErrors $
fmap resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
--------------------------------------------------------------------------------
-- Statements
-- TODO this probably won't scale well (pipes?)
readImport
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Either AppException [Tx ()])
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = 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 paths
runExceptT (matchRecords compiledMatches records)
m <- askDBState kmCurrency
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
where
paths = (root </>) <$> stmtPaths
@ -101,9 +133,9 @@ readImport_
-> m [TxRecord]
readImport_ n delim tns p = do
res <- tryIO $ BL.readFile p
bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> throwIO $ AppException [ParseError $ T.pack m]
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v
where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
@ -112,93 +144,39 @@ readImport_ n delim tns p = do
-- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord
p
TxOpts
{ toDate
, toDesc
, toAmount
, toOther
, toDateFmt
, toSkipBlankDate
, toSkipBlankAmount
, toSkipBlankDescription
, toSkipBlankOther
, toSkipMissingFields
}
r =
do
-- TODO this is confusing as hell
--
-- try and parse all fields; if a parse fails, either trip an error
-- or return a Nothing if we want to deliberately skip missing fields
d <- getField toDate
e <- getField toDesc
os <-
fmap M.fromList . sequence
<$> mapM (\n -> fmap (n,) <$> getField n) toOther
(af, ax) <- case toAmount of
-- the amount column is extra confusing because it can either be one
-- or two columns, so keep track of this with a maybe
AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
f <- getField a1Column
return (a1Fmt, Right <$> f)
AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
f1 <- getField a2Positive
f2 <- getField a2Negative
return $ (a2Fmt,) $ case (f1, f2) of
(Just a, Just b) -> Just $ Left (a, b)
_ -> Nothing
case (d, e, os, ax) of
-- If all lookups were successful, check that none of the fields are
-- blank, and if they are return nothing to skip this line
(Just d', Just e', Just os', Just ax') ->
if (toSkipBlankDate && d' == "")
|| (toSkipBlankDescription && e' == "")
|| (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
|| elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
d <- r .: T.encodeUtf8 toDate
if d == ""
then return Nothing
else -- if we are skipping nothing, proceed to parse the date and amount
-- columns
do
a <- case ax' of
Right a -> parseDecimal True af a
Left ("", a) -> ((-1) *) <$> parseDecimal False af a
Left (a, _) -> parseDecimal False af a
d'' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d'
return $ Just $ TxRecord d'' a e' os' p
-- if no lookups succeeded, return nothing to skip this line. Note that
-- a parse fail will trigger a failure error further up, so that case
-- is already dealt with implicitly
_ -> return Nothing
where
getField :: FromField a => T.Text -> Parser (Maybe a)
getField f = case runParser $ r .: T.encodeUtf8 f of
Left err -> if toSkipMissingFields then return Nothing else fail err
Right x -> return $ Just x
else do
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
e <- r .: T.encodeUtf8 toDesc
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p
matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_
(_, us, ns) -> throwError $ AppException [StatementError us ns]
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
matchPriorities :: [StatementParserRe] -> [MatchGroup]
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
fmap matchToGroup
. L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority)
matchToGroup :: [StatementParserRe] -> MatchGroup
matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup ms =
uncurry MatchGroup $
first (L.sortOn spDate) $
L.partition (isJust . spDate) ms
data MatchGroup = MatchGroup
{ mgDate :: ![StatementParserRe]
, mgNoDate :: ![StatementParserRe]
{ mgDate :: ![MatchRe]
, mgNoDate :: ![MatchRe]
}
deriving (Show)
@ -236,10 +214,9 @@ zipperSlice f x = go
LT -> z
zipperMatch
:: MonadFinance m
=> Unzipped StatementParserRe
:: Unzipped MatchRe
-> TxRecord
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -253,10 +230,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch'
:: MonadFinance m
=> Zipped StatementParserRe
:: Zipped MatchRe
-> TxRecord
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
@ -267,17 +243,13 @@ zipperMatch' z x = go z
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail)
matchDec :: StatementParserRe -> Maybe StatementParserRe
matchDec :: MatchRe -> Maybe MatchRe
matchDec m = case spTimes m of
Just 1 -> Nothing
Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m
matchAll
:: MonadFinance m
=> [MatchGroup]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
@ -287,21 +259,13 @@ matchAll = go ([], [])
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup
:: MonadFinance m
=> MatchGroup
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
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) . spTimes) $ ud ++ un)
matchDates
:: MonadFinance m
=> [StatementParserRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -322,11 +286,7 @@ matchDates ms = go ([], [], initZipper ms)
go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates
:: MonadFinance m
=> [StatementParserRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -343,225 +303,26 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
matches
:: MonadFinance m
=> StatementParserRe
-> TxRecord
-> AppExceptT m (MatchRes (Tx ()))
matches
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
res <- liftInner $
combineError3 val other desc $
\x y z -> x && y && z && date
if res
then maybe (return MatchSkip) convert spTx
else return MatchFail
balanceTx :: RawTx -> InsertExcept BalTx
balanceTx t@Tx {txEntries = ss} = do
bs <- balanceEntries ss
return $ t {txEntries = bs}
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
balanceEntries ss =
fmap concat
<$> mapM (uncurry bal)
$ groupByKey
$ fmap (\s -> (eCurrency s, s)) ss
where
val = valMatches spVal $ toRational trAmount
date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
haeValue s = Left s
bal cur rss
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries 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]
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
toTx
priority
TxGetter
{ tgFrom
, tgTo
, tgCurrency
, tgOtherEntries
, tgScale
}
r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t) ss ->
Tx
{ txMeta = TxMeta trDate priority trDesc ()
, txPrimary =
Left $
EntrySet
{ esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
, txOther = Left <$> ss
}
where
curRes = do
m <- asks tsCurrencyMap
cur <- liftInner $ resolveCurrency m r tgCurrency
let prec = cpPrec cur
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
combineError fromRes toRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
resolveSubGetter
:: MonadFinance m
=> TxRecord
-> TxSubGetter
-> AppExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- asks tsCurrencyMap
cur <- liftInner $ resolveCurrency m r tsgCurrency
let prec = cpPrec cur
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
let valRes = liftInner $ resolveValue prec r tsgValue
liftInner $ combineErrorM toRes valRes $ \t v -> do
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
return $
EntrySet
{ esTotalValue = ()
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
resolveHalfEntry
:: (Precision -> TxRecord -> n -> AppExcept v')
-> Precision
-> TxRecord
-> v
-> TxHalfGetter (EntryGetter n)
-> AppExcept (HalfEntrySet v v')
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es ->
HalfEntrySet
{ hesPrimary =
Entry
{ eAcnt = a
, eValue = v
, eComment = thgComment
, eTags = thgTags
}
, hesOther = es
}
where
acntRes = resolveAcnt r thgAcnt
esRes = mapErrors (resolveEntry f prec r) thgEntries
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept 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
resolveEntry
:: (Precision -> TxRecord -> n -> AppExcept v)
-> Precision
-> TxRecord
-> EntryGetter n
-> AppExcept (Entry AcntID v TagID)
resolveEntry f prec r s@Entry {eAcnt, eValue} =
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
where
acntRes = resolveAcnt r eAcnt
valRes = f prec r eValue
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveFromValue = resolveValue
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveValue prec TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return $ EntryFixed $ go c
AmountN m -> return $ EntryFixed $ trAmount *. m
BalanceN x -> return $ EntryBalance $ go x
PercentN x -> return $ EntryPercent x
where
go = realFracToDecimalP prec
resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
resolveCurrency m r c = do
i <- resolveEntryField CurField r (unCurID <$> c)
case M.lookup (CurID i) m of
Just k -> return k
Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of
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) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
lookup_ = lookupErr (EntryIDField t)
readDouble :: T.Text -> AppExcept Double
readDouble s = case readMaybe $ T.unpack s of
Just x -> return x
Nothing -> throwError $ AppException [ConversionError s True]
readRational :: T.Text -> AppExcept Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
(Just x', Just y') ->
let p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1
in return $ fromInteger x' + k * y' % p
_ -> err
_ -> err
where
readT = readMaybe . T.unpack
err = throwError $ AppException [ConversionError s False]
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
compileOptions = mapM (compileRegex True)
-- compileOptions o@TxOpts {toAmount = pat} = case pat of
-- AmountSingle (TxAmount1 {a1Fmt}) -> do
-- re <- compileRegex True a1Fmt
-- return $ o {toAmountFmt = re}
-- AmountDual (TxAmount2 {a2Fmt}) -> do
-- re <- compileRegex True a2Fmt
-- return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
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
parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
(True, [sign, num]) -> do
k <- readSign sign
x <- readNum num
return $ k * x
(False, [num]) -> readNum num
_ -> msg "malformed decimal"
where
msg :: MonadFail m => T.Text -> m a
msg m =
fail $
T.unpack $
T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
readSign x
| x == "-" = return (-1)
| x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x
readNum x =
maybe
(msg $ T.unwords ["could not parse", singleQuote x])
return
$ readMaybe
$ T.unpack
$ T.filter (/= ',') x
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

164
lib/Internal/Types/Database.hs
View File

@ -7,12 +7,9 @@
-- | Types corresponding to the database model
module Internal.Types.Database where
import Data.Csv (FromField)
import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH
import Internal.Types.Dhall
import RIO
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
@ -20,106 +17,51 @@ share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
CommitR sql=commits
hash CommitHash
hash Int
type ConfigType
UniqueCommitHash hash
deriving Show Eq Ord
ConfigStateR sql=config_state
historySpan HistorySpan
budgetSpan BudgetSpan
deriving Show
deriving Show Eq
CurrencyR sql=currencies
symbol CurID
symbol T.Text
fullname T.Text
precision Precision
UniqueCurrencySymbol symbol
UniqueCurrencyFullname fullname
deriving Show Eq Ord
precision Int
deriving Show Eq
TagR sql=tags
symbol TagID
symbol T.Text
fullname T.Text
UniqueTagSymbol symbol
UniqueTagFullname fullname
deriving Show Eq Ord
deriving Show Eq
AccountR sql=accounts
name T.Text
fullpath AcntPath
fullpath T.Text
desc T.Text
sign AcntSign
leaf Bool
UniqueAccountFullpath fullpath
deriving Show Eq Ord
deriving Show Eq
AccountPathR sql=account_paths
parent AccountRId
child AccountRId
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
depth Int
deriving Show Eq Ord
deriving Show Eq
TransactionR sql=transactions
commit CommitRId
commit CommitRId OnDeleteCascade
date Day
budgetName BudgetName
description TxDesc
priority Int
description T.Text
deriving Show Eq
EntrySetR sql=entry_sets
transaction TransactionRId
currency CurrencyRId
index EntrySetIndex
rebalance Bool
deriving Show Eq
EntryR sql=entries
entryset EntrySetRId
account AccountRId
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text
value Rational
index EntryIndex
cachedValue (Maybe Rational)
cachedType (Maybe TransferType)
cachedLink (Maybe EntryIndex)
deriving Show Eq
TagRelationR sql=tag_relations
entry EntryRId
tag TagRId
entry EntryRId OnDeleteCascade
tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels
entry EntryRId OnDeleteCascade
budgetName T.Text
deriving Show Eq
|]
newtype TxIndex = TxIndex {unTxIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype TxDesc = TxDesc {unTxDesc :: T.Text}
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField, IsString)
newtype Precision = Precision {unPrecision :: Word8}
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
type DaySpan = (Day, Int)
newtype CommitHash = CommitHash {unCommitHash :: Int}
deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
deriving (Eq, Show, Read, Enum, Ord)
data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum)
instance PersistFieldSql ConfigType where
sqlType _ = SqlString
@ -127,61 +69,7 @@ instance PersistFieldSql ConfigType where
instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "not a string"
data AcntSign = Credit | Debit
deriving (Show, Eq, Ord)
instance PersistFieldSql AcntSign where
sqlType _ = SqlInt64
instance PersistField AcntSign where
toPersistValue Debit = PersistInt64 1
toPersistValue Credit = PersistInt64 (-1)
fromPersistValue (PersistInt64 1) = Right Debit
fromPersistValue (PersistInt64 (-1)) = Right Credit
fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
fromPersistValue _ = Left "not an Int64"
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Hashable, Generic, Read)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Hashable, Generic, Read)
acntPath2Text :: AcntPath -> T.Text
acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
instance PersistFieldSql AcntPath where
sqlType _ = SqlString
instance PersistField AcntPath where
toPersistValue = PersistText . acntPath2Text
fromPersistValue (PersistText v) = case T.split (== '/') v of
[] -> Left "path is empty"
(x : xs) -> case readMaybe $ T.unpack x of
Just t -> Right $ AcntPath t xs
_ -> Left "could not get account type"
fromPersistValue _ = Left "not a string"
fromPersistValue _ = Left "wrong type"

281
lib/Internal/Types/Dhall.hs
View File

@ -19,9 +19,9 @@ import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@ -33,14 +33,13 @@ makeHaskellTypesWith
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
, 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 "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
, 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"
@ -49,16 +48,12 @@ makeHaskellTypesWith
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
, SingleConstructor
"Amount"
"Amount"
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
, SingleConstructor
"AcntMatcher_"
"AcntMatcher_"
"\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.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"
@ -66,9 +61,14 @@ makeHaskellTypesWith
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
, SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
, 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
@ -87,13 +87,17 @@ deriveProduct
, "CronPat"
, "DatePat"
, "TaggedAcnt"
, "Budget"
, "Income"
, "ShadowTransfer"
, "TransferMatcher"
, "AcntSet"
, "DateMatcher"
, "ValMatcher"
, "YMDMatcher"
, "BudgetCurrency"
, "Exchange"
, "EntryNumGetter"
, "LinkedNumGetter"
, "LinkedEntryNumGetter"
, "TemporalScope"
, "SqlConfig"
, "PretaxValue"
@ -102,8 +106,8 @@ deriveProduct
, "TaxProgression"
, "TaxMethod"
, "PosttaxValue"
, "TransferValue"
, "TransferType"
, "BudgetTransferValue"
, "BudgetTransferType"
, "Period"
, "PeriodType"
, "HourlyPeriod"
@ -174,45 +178,25 @@ deriving instance Ord DatePat
deriving instance Hashable DatePat
type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
deriving instance Hashable PairedTransfer
deriving instance Hashable BudgetTransfer
deriving instance Generic PairedTransfer
deriving instance Generic BudgetTransfer
deriving instance FromDhall PairedTransfer
newtype BudgetName = BudgetName {unBudgetName :: T.Text}
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
deriving instance FromDhall BudgetTransfer
data Budget = Budget
{ bgtLabel :: !BudgetName
, bgtIncomes :: ![Income]
, bgtPretax :: ![MultiAllocation PretaxValue]
, bgtTax :: ![MultiAllocation TaxValue]
, bgtPosttax :: ![MultiAllocation PosttaxValue]
, bgtTransfers :: ![PairedTransfer]
, bgtShadowTransfers :: ![ShadowTransfer]
{ bgtLabel :: Text
, bgtIncomes :: [Income]
, bgtPretax :: [MultiAllocation PretaxValue]
, bgtTax :: [MultiAllocation TaxValue]
, bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: [BudgetTransfer]
, bgtShadowTransfers :: [ShadowTransfer]
, bgtInterval :: !(Maybe Interval)
}
deriving (Generic, Hashable, FromDhall)
data ShadowTransfer = ShadowTransfer
{ stFrom :: !TaggedAcnt
, stTo :: !TaggedAcnt
, stCurrency :: !CurID
, stDesc :: !Text
, stMatch :: !(TransferMatcher_ Text)
, stRatio :: !Double
}
deriving (Generic, Hashable, FromDhall)
data TransferMatcher_ re = TransferMatcher_
{ tmFrom :: !(Maybe (AcntMatcher_ re))
, tmTo :: !(Maybe (AcntMatcher_ re))
, tmDate :: !(Maybe DateMatcher)
, tmVal :: !ValMatcher
}
deriving instance Hashable PretaxValue
@ -226,28 +210,17 @@ deriving instance Hashable TaxValue
deriving instance Hashable PosttaxValue
deriving instance Hashable TransferValue
deriving instance Hashable Budget
deriving instance Hashable TransferType
deriving instance Hashable BudgetTransferValue
deriving instance Read TransferType
instance PersistFieldSql TransferType where
sqlType _ = SqlString
instance PersistField TransferType where
toPersistValue = PersistText . T.pack . show
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
deriving instance Hashable BudgetTransferType
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
newtype CurID = CurID {unCurID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
type CurID = T.Text
data Income = Income
{ incGross :: Double
@ -259,7 +232,6 @@ data Income = Income
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
, incPayPeriod :: !Period
, incPriority :: !Int
}
deriving instance Hashable HourlyPeriod
@ -278,13 +250,20 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
deriving instance (Show w, Show v) => Show (Amount w v)
deriving instance (Eq w, Eq v) => Eq (Amount w v)
deriving instance Hashable Exchange
deriving instance Hashable BudgetCurrency
data Allocation w v = Allocation
{ alloTo :: TaggedAcnt
, alloAmts :: [Amount w v]
, alloCur :: CurID
}
deriving (Eq, Show, Generic, Hashable)
@ -325,17 +304,11 @@ data Transfer a c w v = Transfer
}
deriving (Eq, Show)
deriving instance Generic (TransferMatcher_ Text)
deriving instance Hashable ShadowTransfer
deriving instance Hashable (TransferMatcher_ Text)
deriving instance Hashable AcntSet
deriving instance FromDhall (TransferMatcher_ Text)
deriving instance Generic (AcntMatcher_ Text)
deriving instance Hashable (AcntMatcher_ Text)
deriving instance FromDhall (AcntMatcher_ Text)
deriving instance Hashable TransferMatcher
deriving instance Hashable ValMatcher
@ -367,10 +340,6 @@ instance Ord DateMatcher where
deriving instance Hashable EntryNumGetter
deriving instance Hashable LinkedNumGetter
deriving instance Hashable LinkedEntryNumGetter
-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
-- account tree type
@ -393,7 +362,7 @@ data AccountRoot_ a = AccountRoot_
, arIncome :: ![a]
, arLiabilities :: ![a]
}
deriving (Generic, Hashable)
deriving (Generic)
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
@ -402,8 +371,10 @@ deriving instance FromDhall AccountRootF
type AccountRoot = AccountRoot_ AccountTree
data Config_ a = Config_
{ scope :: !TemporalScope
{ global :: !TemporalScope
, budget :: ![Budget]
, currencies :: ![Currency]
, statements :: ![History]
, accounts :: !a
, tags :: ![Tag]
, sqlConfig :: !SqlConfig
@ -433,76 +404,55 @@ instance FromDhall a => FromDhall (Config_ a)
-- dhall type overrides (since dhall can't import types with parameters...yet)
-- TODO newtypes for these?
newtype AcntID = AcntID {unAcntID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
type AcntID = T.Text
newtype TagID = TagID {unTagID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
type TagID = T.Text
type HistTransfer = Transfer AcntID CurID DatePat Double
deriving instance Generic HistTransfer
deriving instance Hashable HistTransfer
deriving instance FromDhall HistTransfer
data History
= HistTransfer !PairedTransfer
= HistTransfer !HistTransfer
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter n = Entry EntryAcnt n TagID
type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
type FromEntryGetter = EntryGetter EntryNumGetter
instance FromDhall EntryGetter
type ToEntryGetter = EntryGetter LinkedEntryNumGetter
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
instance FromDhall FromEntryGetter
deriving instance Generic (Entry a v c t)
instance FromDhall ToEntryGetter
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
deriving instance Generic (Entry a v t)
data Tx s = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txEntries :: ![s]
}
deriving (Generic)
deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
type ExpTx = Tx EntryGetter
deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
instance FromDhall ExpTx
deriving instance Eq a => Eq (TxOpts a)
deriving instance Generic (TxOpts a)
deriving instance Hashable (TxOpts T.Text)
deriving instance FromDhall (TxOpts T.Text)
deriving instance Show a => Show (TxOpts a)
deriving instance Eq re => Eq (TxAmount1 re)
deriving instance Eq re => Eq (TxAmount2 re)
deriving instance Show re => Show (TxAmount1 re)
deriving instance Show re => Show (TxAmount2 re)
deriving instance Generic (TxAmount1 T.Text)
deriving instance Generic (TxAmount2 T.Text)
deriving instance Hashable (TxAmount1 T.Text)
deriving instance Hashable (TxAmount2 T.Text)
deriving instance FromDhall (TxAmount1 T.Text)
deriving instance FromDhall (TxAmount2 T.Text)
deriving instance Functor TxAmount1
deriving instance Functor TxAmount2
deriving instance Foldable TxAmount1
deriving instance Foldable TxAmount2
deriving instance Traversable TxAmount1
deriving instance Traversable TxAmount2
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !T.Text
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toAmountFmt :: !re
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data Statement = Statement
{ stmtPaths :: ![FilePath]
@ -511,30 +461,7 @@ data Statement = Statement
, stmtTxOpts :: !(TxOpts T.Text)
, stmtSkipLines :: !Natural
}
deriving (Eq, Hashable, Generic, FromDhall, Show)
data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
deriving (Eq, Show, Functor, Foldable, Traversable)
deriving instance Generic (TxAmountSpec T.Text)
deriving instance FromDhall (TxAmountSpec T.Text)
deriving instance Hashable (TxAmountSpec T.Text)
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !(TxAmountSpec re)
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toSkipBlankDate :: !Bool
, toSkipBlankAmount :: !Bool
, toSkipBlankDescription :: !Bool
, toSkipBlankOther :: ![Text]
, toSkipMissingFields :: !Bool
}
deriving (Functor, Foldable, Traversable)
deriving (Eq, Hashable, Generic, FromDhall)
-- | the value of a field in entry (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map
@ -544,7 +471,7 @@ data EntryTextGetter t
| LookupT !T.Text
| MapT !(FieldMap T.Text t)
| Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)
deriving (Eq, Generic, Hashable, Show, FromDhall)
type EntryCur = EntryTextGetter CurID
@ -576,32 +503,10 @@ data FieldMatcher re
deriving instance Show (FieldMatcher T.Text)
data TxHalfGetter e = TxHalfGetter
{ thgAcnt :: !EntryAcnt
, thgComment :: !T.Text
, thgTags :: ![TagID]
, thgEntries :: ![e]
}
deriving (Eq, Generic, Hashable, Show)
deriving instance FromDhall (TxHalfGetter FromEntryGetter)
deriving instance FromDhall (TxHalfGetter ToEntryGetter)
data TxSubGetter = TxSubGetter
{ tsgFrom :: !(TxHalfGetter FromEntryGetter)
, tsgTo :: !(TxHalfGetter ToEntryGetter)
, tsgValue :: !EntryNumGetter
, tsgCurrency :: !EntryCur
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data TxGetter = TxGetter
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
, tgTo :: !(TxHalfGetter ToEntryGetter)
, tgCurrency :: !EntryCur
, tgOtherEntries :: ![TxSubGetter]
, tgScale :: !Double
{ tgCurrency :: !EntryCur
, tgAcnt :: !EntryAcnt
, tgEntries :: ![EntryGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)

331
lib/Internal/Types/Main.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}
@ -11,11 +12,11 @@ module Internal.Types.Main
where
import Control.Monad.Except
import Data.Decimal
import Database.Persist.Sql hiding (Desc, In, Statement)
import Dhall hiding (embed, maybe)
import Internal.Types.Database
import Internal.Types.Dhall
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
@ -26,166 +27,99 @@ import Text.Regex.TDFA
--------------------------------------------------------------------------------
-- database cache types
type MonadFinance = MonadReader TxState
data DeleteTxs = DeleteTxs
{ dtCommits :: ![CommitRId]
, dtTxs :: ![TransactionRId]
, dtEntrySets :: ![EntrySetRId]
, dtEntries :: ![EntryRId]
, dtTagRelations :: ![TagRelationRId]
}
deriving (Show)
type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
data MetaCRUD = MetaCRUD
{ mcCurrencies :: !(EntityCRUDOps CurrencyR)
, mcAccounts :: !(EntityCRUDOps AccountR)
, mcPaths :: !(EntityCRUDOps AccountPathR)
, mcTags :: !(EntityCRUDOps TagR)
, mcBudgetScope :: !BudgetSpan
, mcHistoryScope :: !HistorySpan
data ConfigHashes = ConfigHashes
{ chIncome :: ![Int]
, chExpense :: ![Int]
, chManual :: ![Int]
, chImport :: ![Int]
}
type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type PreBudgetCRUD = BudgetCRUDOps Budget
type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
type HistoryCRUDOps h =
CRUDOps
h
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
data TxState = TxState
{ tsAccountMap :: !AccountMap
, tsCurrencyMap :: !CurrencyMap
, tsTagMap :: !TagMap
, tsBudgetScope :: !BudgetSpan
, tsHistoryScope :: !HistorySpan
}
deriving (Show)
data ExistingConfig = ExistingConfig
{ ecAccounts :: !(Set AccountRId)
, ecTags :: !(Set TagRId)
, ecCurrencies :: !(Set CurrencyRId)
}
type AccountMap = M.Map AcntID (AccountRId, AcntType)
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
deriving (Show)
type CurrencyMap = M.Map CurID CurrencyPrec
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
type TagMap = M.Map TagID TagRId
data CRUDOps c r u d = CRUDOps
{ coCreate :: !c
, coRead :: !r
, coUpdate :: !u
, coDelete :: !d
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !DaySpan
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
}
deriving (Show)
data CachedEntry
= CachedLink EntryIndex LinkScale
| CachedBalance Decimal
| CachedPercent Double
data TxSortKey = TxSortKey
{ tskDate :: !Day
, tskPriority :: !Int
, tskDesc :: !TxDesc
data DBUpdates = DBUpdates
{ duOldCommits :: ![Int]
, duNewTagIds :: ![Entity TagR]
, duNewAcntPaths :: ![AccountPathR]
, duNewAcntIds :: ![Entity AccountR]
, duNewCurrencyIds :: ![Entity CurrencyR]
}
deriving (Show, Eq, Ord)
-- TODO this should actually be a ReadTx since it will be compared with other
-- Tx's to get the insert/update order correct
data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId
, reAcnt :: !AccountRId
, reValue :: !Decimal
, reIndex :: !EntryIndex
, reESIndex :: !EntrySetIndex
, reSortKey :: !TxSortKey
}
deriving (Show)
type CurrencyM = Reader CurrencyMap
data UpdateEntry i v = UpdateEntry
{ ueID :: !i
, ueAcnt :: !AccountRId
, ueValue :: !v
, ueIndex :: !EntryIndex
}
deriving (Show)
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
deriving instance Functor (UpdateEntry i)
type KeyTx = Tx KeyEntry
newtype LinkScale = LinkScale {unLinkScale :: Double}
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
type TreeR = Tree ([T.Text], AccountRId)
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
deriving newtype (Num, Show)
type MonadFinance = MonadReader DBState
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
type UEUnk = UpdateEntry EntryRId EntryValueUnk
type UELink = UpdateEntry EntryRId LinkScale
type UEBlank = UpdateEntry EntryRId ()
type UE_RO = UpdateEntry () StaticValue
type UEBalanced = UpdateEntry EntryRId StaticValue
data UpdateEntrySet f t = UpdateEntrySet
{ utFrom0 :: !f
, utTo0 :: !UEBlank
, utFromUnk :: ![(UEUnk, [UELink])]
, utToUnk :: ![UEUnk]
, utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO]
, utCurrency :: !CurrencyRId
, utTotalValue :: !t
, utIndex :: !EntrySetIndex
, utSortKey :: !TxSortKey
}
deriving (Show)
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
data EntryCRU
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
| ToRead ReadEntry
| ToInsert (Tx CommitR)
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
-------------------------------------------------------------------------------
-- misc
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord
{ trDate :: !Day
, trAmount :: !Decimal
, trDesc :: !TxDesc
, trAmount :: !Rational
, trDesc :: !T.Text
, trOther :: !(M.Map T.Text T.Text)
, trFile :: !FilePath
}
deriving (Show, Eq, Ord)
type DaySpan = (Day, Natural)
data Keyed a = Keyed
{ kKey :: !Int64
, kVal :: !a
}
deriving (Eq, Show, Functor)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit
deriving (Show)
sign2Int :: AcntSign -> Int
sign2Int Debit = 1
sign2Int Credit = 1
accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit
accountSign ExpenseT = Debit
@ -193,81 +127,21 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
data HalfEntrySet v0 vN = HalfEntrySet
{ hesPrimary :: !(Entry AcntID v0 TagID)
, hesOther :: ![Entry AcntID vN TagID]
}
deriving (Show)
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
data EntrySet v0 vp0 vpN vtN = EntrySet
{ esTotalValue :: !v0
, esCurrency :: !CurrencyRId
, esFrom :: !(HalfEntrySet vp0 vpN)
, esTo :: !(HalfEntrySet () vtN)
}
deriving (Show)
type BalEntry = Entry AcntID Rational CurID TagID
type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
type RawTx = Tx RawEntry
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
type TransferEntrySet = SecondayEntrySet
type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show)
data TxMeta k = TxMeta
{ txmDate :: !Day
, txmPriority :: !Int
, txmDesc :: !TxDesc
, txmCommit :: !k
}
deriving (Show, Eq, Ord)
data Tx k = Tx
{ txMeta :: !(TxMeta k)
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
}
deriving (Generic, Show)
data InsertEntry = InsertEntry
{ ieCached :: !(Maybe CachedEntry)
, ieEntry :: !(Entry AccountRId Decimal TagRId)
}
data InsertEntrySet = InsertEntrySet
{ iesCurrency :: !CurrencyRId
, iesFromEntries :: !(NonEmpty InsertEntry)
, iesToEntries :: !(NonEmpty InsertEntry)
}
data InsertTx = InsertTx
{ itxMeta :: !(TxMeta CommitR)
, itxEntrySets :: !(NonEmpty InsertEntrySet)
}
deriving (Generic)
data EntryValue_ a = EntryValue_ TransferType a
deriving (Show, Functor, Foldable, Traversable)
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
deriving (Show, Eq, Ord)
data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
deriving (Show)
type BalTx = Tx BalEntry
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
--------------------------------------------------------------------------------
-- exception types
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show)
data EntryIDType = AcntField | CurField | TagField deriving (Show)
@ -279,53 +153,50 @@ data LookupSuberr
| DBKey !EntryIDType
deriving (Show)
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data DBLinkSubError
= DBLinkNoScale
| DBLinkNoValue
| DBLinkInvalidValue !Rational !Bool
| DBLinkInvalidBalance
| DBLinkInvalidPercent
deriving (Show)
data DBSubError
= DBShouldBeEmpty
| DBMultiScope
| DBUpdateUnbalanced
| DBLinkError !EntryRId !DBLinkSubError
deriving (Show)
data AppError
data InsertError
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
| AccountTypeError !AcntID !(NE.NonEmpty AcntType)
| StatementIOError !T.Text
| AccountError !AcntID !(NE.NonEmpty AcntType)
| InsertIOError !T.Text
| ParseError !T.Text
| ConversionError !T.Text !Bool
| ConversionError !T.Text
| LookupError !LookupSuberr !T.Text
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| BalanceError !BalanceType !CurID ![RawEntry]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![StatementParserRe]
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
| LinkError !EntryIndex !EntryIndex
| DBError !DBSubError
deriving (Show)
newtype AppException = AppException [AppError]
deriving (Show, Semigroup) via [AppError]
newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [InsertError]
instance Exception AppException
instance Exception InsertException
type MonadAppError = MonadError AppException
type MonadInsertError = MonadError InsertException
type AppExceptT = ExceptT AppException
type InsertExceptT = ExceptT InsertException
type AppExcept = AppExceptT Identity
type InsertExcept = InsertExceptT Identity
type StatementParserRe = StatementParser (T.Text, Regex)
data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
type TransferMatcherRe = TransferMatcher_ Regex
type MatchRe = StatementParser (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex)

1026
lib/Internal/Utils.hs
View File

File diff suppressed because it is too large Load Diff

1
package.yaml
View File

@ -87,7 +87,6 @@ dependencies:
- filepath
- mtl
- persistent-mtl >= 0.3.0.0
- Decimal >= 0.5.2
library:
source-dirs: lib/