Compare commits
No commits in common. "master" and "add_budget_limits" have entirely different histories.
master
...
add_budget
118
app/Main.hs
118
app/Main.hs
|
@ -2,21 +2,21 @@
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
import Control.Monad.IO.Rerunnable
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Data.Bitraversable
|
import Control.Monad.Reader
|
||||||
-- import Data.Hashable
|
|
||||||
import qualified Data.Text.IO as TI
|
import qualified Data.Text.IO as TI
|
||||||
import qualified Database.Esqueleto.Experimental as E
|
import Database.Persist.Monad
|
||||||
import qualified Dhall hiding (double, record)
|
import Dhall hiding (double, record)
|
||||||
|
import Internal.Budget
|
||||||
import Internal.Database
|
import Internal.Database
|
||||||
|
import Internal.History
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
-- import qualified RIO.Map as M
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -30,26 +30,14 @@ main = parse =<< execParser o
|
||||||
<> header "pwncash - your budget, your life"
|
<> header "pwncash - your budget, your life"
|
||||||
)
|
)
|
||||||
|
|
||||||
type ConfigPath = FilePath
|
data Options = Options FilePath Mode
|
||||||
|
|
||||||
type BudgetPath = FilePath
|
|
||||||
|
|
||||||
type HistoryPath = FilePath
|
|
||||||
|
|
||||||
data Options = Options !ConfigPath !Mode
|
|
||||||
|
|
||||||
data Mode
|
data Mode
|
||||||
= Reset
|
= Reset
|
||||||
| DumpCurrencies
|
| DumpCurrencies
|
||||||
| DumpAccounts
|
| DumpAccounts
|
||||||
| DumpAccountKeys
|
| DumpAccountKeys
|
||||||
| Sync !SyncOptions
|
| Sync
|
||||||
|
|
||||||
data SyncOptions = SyncOptions
|
|
||||||
{ syncBudgets :: ![BudgetPath]
|
|
||||||
, syncHistories :: ![HistoryPath]
|
|
||||||
, syncThreads :: !Int
|
|
||||||
}
|
|
||||||
|
|
||||||
configFile :: Parser FilePath
|
configFile :: Parser FilePath
|
||||||
configFile =
|
configFile =
|
||||||
|
@ -67,7 +55,7 @@ options =
|
||||||
<|> getConf dumpCurrencies
|
<|> getConf dumpCurrencies
|
||||||
<|> getConf dumpAccounts
|
<|> getConf dumpAccounts
|
||||||
<|> getConf dumpAccountKeys
|
<|> getConf dumpAccountKeys
|
||||||
<|> getConf sync_
|
<|> getConf sync
|
||||||
where
|
where
|
||||||
getConf m = Options <$> configFile <*> m
|
getConf m = Options <$> configFile <*> m
|
||||||
|
|
||||||
|
@ -108,43 +96,14 @@ dumpAccountKeys =
|
||||||
<> help "Dump all account keys/aliases"
|
<> help "Dump all account keys/aliases"
|
||||||
)
|
)
|
||||||
|
|
||||||
sync_ :: Parser Mode
|
sync :: Parser Mode
|
||||||
sync_ =
|
sync =
|
||||||
flag'
|
flag'
|
||||||
Sync
|
Sync
|
||||||
( long "sync"
|
( long "sync"
|
||||||
<> short 'S'
|
<> short 'S'
|
||||||
<> help "Sync config to database"
|
<> 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 -> IO ()
|
||||||
parse (Options c Reset) = do
|
parse (Options c Reset) = do
|
||||||
|
@ -153,8 +112,7 @@ parse (Options c Reset) = do
|
||||||
parse (Options c DumpAccounts) = runDumpAccounts c
|
parse (Options c DumpAccounts) = runDumpAccounts c
|
||||||
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
|
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
|
||||||
parse (Options c DumpCurrencies) = runDumpCurrencies c
|
parse (Options c DumpCurrencies) = runDumpCurrencies c
|
||||||
parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
|
parse (Options c Sync) = runSync c
|
||||||
runSync syncThreads c syncBudgets syncHistories
|
|
||||||
|
|
||||||
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
|
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runDumpCurrencies c = do
|
runDumpCurrencies c = do
|
||||||
|
@ -192,34 +150,50 @@ runDumpAccountKeys c = do
|
||||||
ar <- accounts <$> readConfig c
|
ar <- accounts <$> readConfig c
|
||||||
let ks =
|
let ks =
|
||||||
paths2IDs $
|
paths2IDs $
|
||||||
fmap (double . accountRFullpath . E.entityVal) $
|
fmap (double . fst) $
|
||||||
fst $
|
concatMap (t3 . uncurry tree2Records) $
|
||||||
indexAcntRoot ar
|
flattenAcntRoot ar
|
||||||
mapM_ (uncurry printPair) ks
|
mapM_ (uncurry printPair) ks
|
||||||
where
|
where
|
||||||
printPair i p = do
|
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)
|
double x = (x, x)
|
||||||
|
|
||||||
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
runSync :: FilePath -> IO ()
|
||||||
runSync threads c bs hs = do
|
runSync c = do
|
||||||
setNumCapabilities threads
|
|
||||||
config <- readConfig c
|
config <- readConfig c
|
||||||
(bs', hs') <-
|
let (hTs, hSs) = splitHistory $ statements config
|
||||||
fmap (bimap concat concat . partitionEithers) $
|
|
||||||
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
|
|
||||||
(Left <$> bs) ++ (Right <$> hs)
|
|
||||||
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
||||||
setNumCapabilities 1
|
handle err $ do
|
||||||
handle err $ sync pool root config bs' hs'
|
-- _ <- 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
|
where
|
||||||
root = takeDirectory c
|
root = takeDirectory c
|
||||||
err (AppException es) = do
|
err (InsertException es) = do
|
||||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||||
exitFailure
|
exitFailure
|
||||||
|
|
||||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
-- showBalances
|
||||||
readConfig = fmap unfix . readDhall
|
|
||||||
|
|
||||||
readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
|
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||||
readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath
|
readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath
|
||||||
|
|
|
@ -75,8 +75,7 @@ library
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
||||||
build-depends:
|
build-depends:
|
||||||
Decimal >=0.5.2
|
base >=4.12 && <10
|
||||||
, base >=4.12 && <10
|
|
||||||
, cassava
|
, cassava
|
||||||
, conduit >=1.3.4.2
|
, conduit >=1.3.4.2
|
||||||
, containers >=0.6.4.1
|
, containers >=0.6.4.1
|
||||||
|
@ -145,8 +144,7 @@ executable pwncash
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
||||||
build-depends:
|
build-depends:
|
||||||
Decimal >=0.5.2
|
base >=4.12 && <10
|
||||||
, base >=4.12 && <10
|
|
||||||
, budget
|
, budget
|
||||||
, cassava
|
, cassava
|
||||||
, conduit >=1.3.4.2
|
, conduit >=1.3.4.2
|
||||||
|
|
|
@ -278,124 +278,49 @@ let DatePat =
|
||||||
-}
|
-}
|
||||||
< Cron : CronPat.Type | Mod : ModPat.Type >
|
< 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) ->
|
|
||||||
{ toDate :
|
|
||||||
{-
|
|
||||||
Column title for date
|
|
||||||
-}
|
|
||||||
Text
|
|
||||||
, toAmount :
|
|
||||||
{-
|
|
||||||
Column title for amount
|
|
||||||
-}
|
|
||||||
TxAmountSpec_ re
|
|
||||||
, toDesc :
|
|
||||||
{-
|
|
||||||
Column title for description
|
|
||||||
-}
|
|
||||||
Text
|
|
||||||
, toOther :
|
|
||||||
{-
|
|
||||||
Titles of other columns to include; these will be available in
|
|
||||||
a map for use in downstream processing (see 'Field')
|
|
||||||
-}
|
|
||||||
List Text
|
|
||||||
, toDateFmt :
|
|
||||||
{-
|
|
||||||
Format of the date field as specified in the
|
|
||||||
Data.Time.Format.formattime Haskell function.
|
|
||||||
-}
|
|
||||||
Text
|
|
||||||
, toSkipBlankDate :
|
|
||||||
{-
|
|
||||||
Skip line if date field is a blank
|
|
||||||
-}
|
|
||||||
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
|
|
||||||
}
|
|
||||||
|
|
||||||
let TxAmountSpec = TxAmountSpec_ Text
|
|
||||||
|
|
||||||
let TxOpts =
|
let TxOpts =
|
||||||
{ Type = TxOpts_ Text
|
{- Additional metadata to use when parsing a statement -}
|
||||||
|
{ Type =
|
||||||
|
{ toDate :
|
||||||
|
{-
|
||||||
|
Column title for date
|
||||||
|
-}
|
||||||
|
Text
|
||||||
|
, toAmount :
|
||||||
|
{-
|
||||||
|
Column title for amount
|
||||||
|
-}
|
||||||
|
Text
|
||||||
|
, toDesc :
|
||||||
|
{-
|
||||||
|
Column title for description
|
||||||
|
-}
|
||||||
|
Text
|
||||||
|
, toOther :
|
||||||
|
{-
|
||||||
|
Titles of other columns to include; these will be available in
|
||||||
|
a map for use in downstream processing (see 'Field')
|
||||||
|
-}
|
||||||
|
List Text
|
||||||
|
, toDateFmt :
|
||||||
|
{-
|
||||||
|
Format of the date field as specified in the
|
||||||
|
Data.Time.Format.formattime Haskell function.
|
||||||
|
-}
|
||||||
|
Text
|
||||||
|
, toAmountFmt :
|
||||||
|
{- Format of the amount field. Must include three fields for the
|
||||||
|
sign, numerator, and denominator of the amount.
|
||||||
|
-}
|
||||||
|
Text
|
||||||
|
}
|
||||||
, default =
|
, default =
|
||||||
{ toDate = "Date"
|
{ toDate = "Date"
|
||||||
, toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
|
, toAmount = "Amount"
|
||||||
, toDesc = "Description"
|
, toDesc = "Description"
|
||||||
, toOther = [] : List Text
|
, toOther = [] : List Text
|
||||||
, toDateFmt = "%0m/%0d/%Y"
|
, toDateFmt = "%0m/%0d/%Y"
|
||||||
, toSkipBlankDate = False
|
, toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
|
||||||
, toSkipBlankAmount = False
|
|
||||||
, toSkipBlankDescription = False
|
|
||||||
, toSkipBlankOther = [] : List Text
|
|
||||||
, toSkipMissingFields = False
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -477,45 +402,9 @@ let EntryNumGetter =
|
||||||
|
|
||||||
LookupN: lookup the value from a field
|
LookupN: lookup the value from a field
|
||||||
ConstN: a constant value
|
ConstN: a constant value
|
||||||
AmountN: the value of the 'Amount' column times a scaling factor
|
AmountN: the value of the 'Amount' column
|
||||||
BalanceN: the amount required to make the target account reach a balance
|
|
||||||
PercentN: the amount required to make an account reach a given percentage
|
|
||||||
-}
|
-}
|
||||||
< LookupN : Text
|
< LookupN : Text | ConstN : Double | AmountN : Double >
|
||||||
| 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 >
|
|
||||||
|
|
||||||
let EntryTextGetter =
|
let EntryTextGetter =
|
||||||
{-
|
{-
|
||||||
|
@ -554,6 +443,7 @@ let Entry =
|
||||||
-}
|
-}
|
||||||
\(a : Type) ->
|
\(a : Type) ->
|
||||||
\(v : Type) ->
|
\(v : Type) ->
|
||||||
|
\(c : Type) ->
|
||||||
\(t : Type) ->
|
\(t : Type) ->
|
||||||
{ eAcnt :
|
{ eAcnt :
|
||||||
{-
|
{-
|
||||||
|
@ -565,6 +455,11 @@ let Entry =
|
||||||
Pertains to value for this entry.
|
Pertains to value for this entry.
|
||||||
-}
|
-}
|
||||||
v
|
v
|
||||||
|
, eCurrency :
|
||||||
|
{-
|
||||||
|
Pertains to value for this entry.
|
||||||
|
-}
|
||||||
|
c
|
||||||
, eComment :
|
, eComment :
|
||||||
{-
|
{-
|
||||||
A short description of this entry (if none, use a blank string)
|
A short description of this entry (if none, use a blank string)
|
||||||
|
@ -579,107 +474,35 @@ let Entry =
|
||||||
|
|
||||||
let EntryGetter =
|
let EntryGetter =
|
||||||
{-
|
{-
|
||||||
Means for getting an entry from a given row in a statement (debit side)
|
Means for getting an entry from a given row in a statement
|
||||||
-}
|
|
||||||
\(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
|
|
||||||
-}
|
-}
|
||||||
{ Type =
|
{ Type =
|
||||||
{ tsgValue : EntryNumGetter
|
Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
|
||||||
, tsgCurrency : EntryCurGetter
|
, default = { eValue = None EntryNumGetter, eComment = "" }
|
||||||
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
|
||||||
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
|
||||||
}
|
|
||||||
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let TxGetter =
|
let TxGetter =
|
||||||
{-
|
{-
|
||||||
A means for transforming one row in a statement to a transaction
|
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 =
|
{ tgEntries :
|
||||||
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
{-
|
||||||
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
A means of getting entries for this transaction (minimum 1)
|
||||||
, tgScale : Double
|
-}
|
||||||
, tgCurrency : EntryCurGetter
|
List EntryGetter.Type
|
||||||
, tgOtherEntries : List TxSubGetter.Type
|
, tgCurrency :
|
||||||
}
|
{-
|
||||||
, default =
|
Currency against which entries in this transaction will be balanced
|
||||||
{ tgOtherEntries = [] : List TxSubGetter.Type
|
-}
|
||||||
, tgFrom = TxHalfGetter
|
EntryCurGetter
|
||||||
, tgTo = TxHalfGetter
|
, tgAcnt :
|
||||||
, tgScale = 1.0
|
{-
|
||||||
}
|
Account in which entries in this transaction will be balanced
|
||||||
|
-}
|
||||||
|
EntryAcntGetter
|
||||||
}
|
}
|
||||||
|
|
||||||
let StatementParser_ =
|
let StatementParser_ =
|
||||||
|
@ -719,7 +542,7 @@ let StatementParser_ =
|
||||||
a transaction. If none, don't make a transaction (eg 'skip'
|
a transaction. If none, don't make a transaction (eg 'skip'
|
||||||
this row in the statement).
|
this row in the statement).
|
||||||
-}
|
-}
|
||||||
Optional TxGetter.Type
|
Optional TxGetter
|
||||||
, spTimes :
|
, spTimes :
|
||||||
{-
|
{-
|
||||||
Match at most this many rows; if none there is no limit
|
Match at most this many rows; if none there is no limit
|
||||||
|
@ -736,7 +559,7 @@ let StatementParser_ =
|
||||||
, spVal = ValMatcher::{=}
|
, spVal = ValMatcher::{=}
|
||||||
, spDesc = None Text
|
, spDesc = None Text
|
||||||
, spOther = [] : List (FieldMatcher_ re)
|
, spOther = [] : List (FieldMatcher_ re)
|
||||||
, spTx = None TxGetter.Type
|
, spTx = None TxGetter
|
||||||
, spTimes = None Natural
|
, spTimes = None Natural
|
||||||
, spPriority = +0
|
, spPriority = +0
|
||||||
}
|
}
|
||||||
|
@ -754,29 +577,7 @@ let Amount =
|
||||||
-}
|
-}
|
||||||
\(w : Type) ->
|
\(w : Type) ->
|
||||||
\(v : Type) ->
|
\(v : Type) ->
|
||||||
{ Type =
|
{ amtWhen : w, amtValue : v, amtDesc : Text }
|
||||||
{ 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
|
|
||||||
}
|
|
||||||
|
|
||||||
let Transfer =
|
let Transfer =
|
||||||
{-
|
{-
|
||||||
|
@ -789,24 +590,14 @@ let Transfer =
|
||||||
{ transFrom : a
|
{ transFrom : a
|
||||||
, transTo : a
|
, transTo : a
|
||||||
, transCurrency : c
|
, transCurrency : c
|
||||||
, transAmounts : List (Amount w v).Type
|
, transAmounts : List (Amount w v)
|
||||||
}
|
}
|
||||||
|
|
||||||
let TaggedAcnt =
|
|
||||||
{-
|
|
||||||
An account with a tag
|
|
||||||
-}
|
|
||||||
{ Type = { taAcnt : AcntID, taTags : List TagID }
|
|
||||||
, default.taTags = [] : List TagID
|
|
||||||
}
|
|
||||||
|
|
||||||
let HistTransfer =
|
let HistTransfer =
|
||||||
{-
|
{-
|
||||||
A manually specified historical transfer
|
A manually specified historical transfer
|
||||||
-}
|
-}
|
||||||
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
|
Transfer AcntID CurID DatePat Double
|
||||||
|
|
||||||
let TransferAmount = Amount DatePat TransferValue.Type
|
|
||||||
|
|
||||||
let Statement =
|
let Statement =
|
||||||
{-
|
{-
|
||||||
|
@ -843,6 +634,44 @@ let History =
|
||||||
-}
|
-}
|
||||||
< HistTransfer : HistTransfer | HistStatement : Statement >
|
< 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 =
|
let Allocation =
|
||||||
{-
|
{-
|
||||||
How to allocate a given budget stream. This can be thought of as a Transfer
|
How to allocate a given budget stream. This can be thought of as a Transfer
|
||||||
|
@ -850,7 +679,12 @@ let Allocation =
|
||||||
-}
|
-}
|
||||||
\(w : Type) ->
|
\(w : Type) ->
|
||||||
\(v : 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 =
|
let PretaxValue =
|
||||||
{-
|
{-
|
||||||
|
@ -945,8 +779,6 @@ let SingleAllocation =
|
||||||
-}
|
-}
|
||||||
Allocation {}
|
Allocation {}
|
||||||
|
|
||||||
let SingleAlloAmount = \(v : Type) -> Amount {} v
|
|
||||||
|
|
||||||
let MultiAllocation =
|
let MultiAllocation =
|
||||||
{-
|
{-
|
||||||
An allocation specialized to capturing multiple income streams within a given
|
An allocation specialized to capturing multiple income streams within a given
|
||||||
|
@ -955,8 +787,6 @@ let MultiAllocation =
|
||||||
-}
|
-}
|
||||||
Allocation Interval
|
Allocation Interval
|
||||||
|
|
||||||
let MultiAlloAmount = \(v : Type) -> Amount Interval v
|
|
||||||
|
|
||||||
let HourlyPeriod =
|
let HourlyPeriod =
|
||||||
{-
|
{-
|
||||||
Definition for a pay period denominated in hours
|
Definition for a pay period denominated in hours
|
||||||
|
@ -1039,62 +869,85 @@ let Income =
|
||||||
This must be an income AcntID, and is the only place income
|
This must be an income AcntID, and is the only place income
|
||||||
accounts may be specified in the entire budget.
|
accounts may be specified in the entire budget.
|
||||||
-}
|
-}
|
||||||
TaggedAcnt.Type
|
TaggedAcnt
|
||||||
, incToBal :
|
, incToBal :
|
||||||
{-
|
{-
|
||||||
The account to which to send the remainder of the income stream
|
The account to which to send the remainder of the income stream
|
||||||
(if any) after all allocations have been applied.
|
(if any) after all allocations have been applied.
|
||||||
-}
|
-}
|
||||||
TaggedAcnt.Type
|
TaggedAcnt
|
||||||
, incPriority : Integer
|
|
||||||
}
|
}
|
||||||
, default =
|
, default =
|
||||||
{ incPretax = [] : List (SingleAllocation PretaxValue)
|
{ incPretax = [] : List (SingleAllocation PretaxValue)
|
||||||
, incTaxes = [] : List (SingleAllocation TaxValue)
|
, incTaxes = [] : List (SingleAllocation TaxValue)
|
||||||
, incPosttaxx = [] : List (SingleAllocation PosttaxValue)
|
, 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 =
|
||||||
{ Type = { amPat : re, amInvert : Bool }, default.amInvert = False }
|
{ 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
|
Means to match a transfer (which will be used to "clone" it in some
|
||||||
fashion)
|
fashion)
|
||||||
-}
|
-}
|
||||||
\(re : Type) ->
|
{ Type =
|
||||||
{ tmFrom : Optional (AcntMatcher_ re).Type
|
{ tmFrom :
|
||||||
, tmTo : Optional (AcntMatcher_ re).Type
|
{-
|
||||||
, tmDate :
|
List of accounts (which may be empty) to match with the
|
||||||
{-
|
starting account in a transfer.
|
||||||
If given, means to match the date of a transfer.
|
-}
|
||||||
-}
|
AcntSet.Type
|
||||||
Optional DateMatcher
|
, tmTo :
|
||||||
, tmVal :
|
{-
|
||||||
{-
|
List of accounts (which may be empty) to match with the
|
||||||
If given, means to match the value of a transfer.
|
ending account in a transfer.
|
||||||
-}
|
-}
|
||||||
ValMatcher.Type
|
AcntSet.Type
|
||||||
}
|
, tmDate :
|
||||||
|
{-
|
||||||
let TransferMatcher =
|
If given, means to match the date of a transfer.
|
||||||
{ Type = TransferMatcher_ Text
|
-}
|
||||||
|
Optional DateMatcher
|
||||||
|
, tmVal :
|
||||||
|
{-
|
||||||
|
If given, means to match the value of a transfer.
|
||||||
|
-}
|
||||||
|
ValMatcher.Type
|
||||||
|
}
|
||||||
, default =
|
, default =
|
||||||
{ tmFrom = None AcntMatcher.Type
|
{ tmFrom = AcntSet.default
|
||||||
, tmTo = None AcntMatcher.Type
|
, tmTo = AcntSet.default
|
||||||
, tmDate = None DateMatcher
|
, tmDate = None DateMatcher
|
||||||
, tmVal = ValMatcher.default
|
, 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 =
|
let ShadowTransfer =
|
||||||
{-
|
{-
|
||||||
A transaction analogous to another transfer with given properties.
|
A transaction analogous to another transfer with given properties.
|
||||||
|
@ -1103,17 +956,17 @@ let ShadowTransfer =
|
||||||
{-
|
{-
|
||||||
Source of this transfer
|
Source of this transfer
|
||||||
-}
|
-}
|
||||||
TaggedAcnt.Type
|
TaggedAcnt
|
||||||
, stTo :
|
, stTo :
|
||||||
{-
|
{-
|
||||||
Destination of this transfer.
|
Destination of this transfer.
|
||||||
-}
|
-}
|
||||||
TaggedAcnt.Type
|
TaggedAcnt
|
||||||
, stCurrency :
|
, stCurrency :
|
||||||
{-
|
{-
|
||||||
Currency of this transfer.
|
Currency of this transfer.
|
||||||
-}
|
-}
|
||||||
CurID
|
BudgetCurrency
|
||||||
, stDesc :
|
, stDesc :
|
||||||
{-
|
{-
|
||||||
Description of this transfer.
|
Description of this transfer.
|
||||||
|
@ -1127,6 +980,7 @@ let ShadowTransfer =
|
||||||
specified in other fields of this type.
|
specified in other fields of this type.
|
||||||
-}
|
-}
|
||||||
TransferMatcher.Type
|
TransferMatcher.Type
|
||||||
|
, stType : BudgetTransferType
|
||||||
, stRatio :
|
, stRatio :
|
||||||
{-
|
{-
|
||||||
Fixed multipler to translate value of matched transfer to this one.
|
Fixed multipler to translate value of matched transfer to this one.
|
||||||
|
@ -1134,11 +988,17 @@ let ShadowTransfer =
|
||||||
Double
|
Double
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let BudgetTransferValue =
|
||||||
|
{-
|
||||||
|
Means to determine the value of a budget transfer.
|
||||||
|
-}
|
||||||
|
{ btVal : Double, btType : BudgetTransferType }
|
||||||
|
|
||||||
let BudgetTransfer =
|
let BudgetTransfer =
|
||||||
{-
|
{-
|
||||||
A manually specified transaction for a budget
|
A manually specified transaction for a budget
|
||||||
-}
|
-}
|
||||||
HistTransfer
|
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
||||||
|
|
||||||
let Budget =
|
let Budget =
|
||||||
{-
|
{-
|
||||||
|
@ -1180,7 +1040,6 @@ in { CurID
|
||||||
, CronPat
|
, CronPat
|
||||||
, DatePat
|
, DatePat
|
||||||
, TxOpts
|
, TxOpts
|
||||||
, TxOpts_
|
|
||||||
, StatementParser
|
, StatementParser
|
||||||
, StatementParser_
|
, StatementParser_
|
||||||
, ValMatcher
|
, ValMatcher
|
||||||
|
@ -1189,13 +1048,10 @@ in { CurID
|
||||||
, FieldMatcher
|
, FieldMatcher
|
||||||
, FieldMatcher_
|
, FieldMatcher_
|
||||||
, EntryNumGetter
|
, EntryNumGetter
|
||||||
, LinkedEntryNumGetter
|
|
||||||
, LinkedNumGetter
|
|
||||||
, Field
|
, Field
|
||||||
, FieldMap
|
, FieldMap
|
||||||
, Entry
|
, Entry
|
||||||
, FromEntryGetter
|
, EntryGetter
|
||||||
, ToEntryGetter
|
|
||||||
, EntryTextGetter
|
, EntryTextGetter
|
||||||
, EntryCurGetter
|
, EntryCurGetter
|
||||||
, EntryAcntGetter
|
, EntryAcntGetter
|
||||||
|
@ -1206,11 +1062,12 @@ in { CurID
|
||||||
, Budget
|
, Budget
|
||||||
, Allocation
|
, Allocation
|
||||||
, Amount
|
, Amount
|
||||||
, TransferMatcher_
|
|
||||||
, TransferMatcher
|
, TransferMatcher
|
||||||
, ShadowTransfer
|
, ShadowTransfer
|
||||||
|
, AcntSet
|
||||||
|
, BudgetCurrency
|
||||||
|
, Exchange
|
||||||
, TaggedAcnt
|
, TaggedAcnt
|
||||||
, AccountTree
|
|
||||||
, Account
|
, Account
|
||||||
, Placeholder
|
, Placeholder
|
||||||
, PretaxValue
|
, PretaxValue
|
||||||
|
@ -1219,29 +1076,13 @@ in { CurID
|
||||||
, TaxProgression
|
, TaxProgression
|
||||||
, TaxMethod
|
, TaxMethod
|
||||||
, TaxValue
|
, TaxValue
|
||||||
, TransferValue
|
, BudgetTransferValue
|
||||||
, TransferType
|
, BudgetTransferType
|
||||||
, TxGetter
|
, TxGetter
|
||||||
, TxSubGetter
|
|
||||||
, TxHalfGetter
|
|
||||||
, FromTxHalfGetter
|
|
||||||
, ToTxHalfGetter
|
|
||||||
, HistTransfer
|
, HistTransfer
|
||||||
, SingleAllocation
|
, SingleAllocation
|
||||||
, MultiAllocation
|
, MultiAllocation
|
||||||
, HourlyPeriod
|
, HourlyPeriod
|
||||||
, Period
|
, Period
|
||||||
, PeriodType
|
, PeriodType
|
||||||
, TransferAmount
|
|
||||||
, MultiAlloAmount
|
|
||||||
, SingleAlloAmount
|
|
||||||
, AcntMatcher_
|
|
||||||
, AcntMatcher
|
|
||||||
, TxAmountSpec
|
|
||||||
, TxAmountSpec_
|
|
||||||
, TxAmount1_
|
|
||||||
, TxAmount2_
|
|
||||||
, TxAmount1
|
|
||||||
, TxAmount2
|
|
||||||
, BudgetTransfer
|
|
||||||
}
|
}
|
||||||
|
|
|
@ -4,10 +4,18 @@ let List/map =
|
||||||
|
|
||||||
let T = ./Types.dhall
|
let T = ./Types.dhall
|
||||||
|
|
||||||
let nullEntry =
|
let nullSplit =
|
||||||
\(a : T.EntryAcntGetter) ->
|
\(a : T.EntryAcntGetter) ->
|
||||||
\(v : T.EntryNumGetter) ->
|
\(c : T.EntryCurGetter) ->
|
||||||
T.FromEntryGetter::{ eAcnt = a, eValue = v }
|
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 =
|
let nullMod =
|
||||||
\(by : Natural) ->
|
\(by : Natural) ->
|
||||||
|
@ -19,22 +27,21 @@ let cron1 =
|
||||||
\(m : Natural) ->
|
\(m : Natural) ->
|
||||||
\(d : Natural) ->
|
\(d : Natural) ->
|
||||||
T.DatePat.Cron
|
T.DatePat.Cron
|
||||||
T.CronPat::{
|
( nullCron
|
||||||
, cpYear = Some (T.MDYPat.Single y)
|
// { cpYear = Some (T.MDYPat.Single y)
|
||||||
, cpMonth = Some (T.MDYPat.Single m)
|
, cpMonth = Some (T.MDYPat.Single m)
|
||||||
, cpDay = Some (T.MDYPat.Single d)
|
, 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 =
|
let matchN =
|
||||||
\(n : Natural) ->
|
\(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
|
||||||
\(x : T.TxGetter.Type) ->
|
|
||||||
matchInf x // { spTimes = Some n }
|
|
||||||
|
|
||||||
let match1_ = matchN_ 1
|
let match1_ = matchN_ 1
|
||||||
|
|
||||||
|
@ -79,45 +86,46 @@ let mRngYMD =
|
||||||
\(r : Natural) ->
|
\(r : Natural) ->
|
||||||
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
|
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 =
|
let partN =
|
||||||
\(ss : List PartEntry) ->
|
\(c : T.EntryCurGetter) ->
|
||||||
let toEntry =
|
\(a : T.EntryAcntGetter) ->
|
||||||
\(x : PartEntry) ->
|
\(comment : Text) ->
|
||||||
T.FromEntryGetter::{
|
\(ss : List PartSplit) ->
|
||||||
, eAcnt = T.EntryAcntGetter.ConstT x._1
|
let toSplit =
|
||||||
, eValue = T.EntryNumGetter.ConstN x._2
|
\(x : PartSplit) ->
|
||||||
, eComment = x._3
|
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 =
|
let part1 =
|
||||||
\(ss : List PartEntry) ->
|
\(c : T.EntryCurGetter) ->
|
||||||
let toEntry =
|
\(a : T.EntryAcntGetter) ->
|
||||||
\(x : PartEntry) ->
|
\(comment : Text) ->
|
||||||
T.ToEntryGetter::{
|
partN c a comment ([] : List PartSplit)
|
||||||
, eAcnt = T.EntryAcntGetter.ConstT x._1
|
|
||||||
, eValue =
|
|
||||||
T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
|
|
||||||
, eComment = x._3
|
|
||||||
}
|
|
||||||
|
|
||||||
in List/map PartEntry T.ToEntryGetter.Type toEntry ss
|
let part1_ =
|
||||||
|
\(c : T.EntryCurGetter) ->
|
||||||
|
\(a : T.EntryAcntGetter) ->
|
||||||
|
partN c a "" ([] : List PartSplit)
|
||||||
|
|
||||||
let addDay =
|
let addDay =
|
||||||
\(x : T.GregorianM) ->
|
\(x : T.GregorianM) ->
|
||||||
\(d : Natural) ->
|
\(d : Natural) ->
|
||||||
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
|
{ 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 }
|
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 }
|
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
|
||||||
|
|
||||||
in { cron1
|
in { nullSplit
|
||||||
|
, nullMatch
|
||||||
|
, nullVal
|
||||||
|
, nullOpts
|
||||||
|
, nullCron
|
||||||
|
, nullMod
|
||||||
|
, cron1
|
||||||
, mY
|
, mY
|
||||||
, mYM
|
, mYM
|
||||||
, mYMD
|
, mYMD
|
||||||
|
@ -142,8 +156,9 @@ in { cron1
|
||||||
, match1
|
, match1
|
||||||
, greg
|
, greg
|
||||||
, gregM
|
, gregM
|
||||||
, partNFrom
|
, partN
|
||||||
, partNTo
|
, part1
|
||||||
|
, part1_
|
||||||
, addDay
|
, addDay
|
||||||
, comma = 44
|
, comma = 44
|
||||||
, tab = 9
|
, tab = 9
|
||||||
|
@ -155,8 +170,6 @@ in { cron1
|
||||||
, mvDen
|
, mvDen
|
||||||
, mvDenP
|
, mvDenP
|
||||||
, mvDenN
|
, mvDenN
|
||||||
, PartEntry
|
, PartSplit
|
||||||
, nullEntry
|
|
||||||
, nullMod
|
|
||||||
}
|
}
|
||||||
/\ T
|
/\ T
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
module Internal.Budget (readBudgetCRUD) where
|
module Internal.Budget (insertBudget) where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Decimal hiding (allocate)
|
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.Hashable
|
import Database.Persist.Monad
|
||||||
|
import Internal.Database
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
|
@ -13,13 +13,22 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
|
-- each budget (designated at the top level by a 'name') is processed in the
|
||||||
readBudgetCRUD o@CRUDOps {coCreate} = do
|
-- following steps
|
||||||
bs <- mapM readBudget coCreate
|
-- 1. expand all transactions given the desired date range and date patterns for
|
||||||
return $ o {coCreate = bs}
|
-- 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])
|
insertBudget
|
||||||
readBudget
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
=> Budget
|
||||||
|
-> m ()
|
||||||
|
insertBudget
|
||||||
b@Budget
|
b@Budget
|
||||||
{ bgtLabel
|
{ bgtLabel
|
||||||
, bgtIncomes
|
, bgtIncomes
|
||||||
|
@ -30,18 +39,15 @@ readBudget
|
||||||
, bgtPosttax
|
, bgtPosttax
|
||||||
, bgtInterval
|
, bgtInterval
|
||||||
} =
|
} =
|
||||||
do
|
whenHash CTBudget b () $ \key -> do
|
||||||
spanRes <- getSpan
|
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||||
(bgtLabel,) <$> case spanRes of
|
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
||||||
Nothing -> return []
|
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
||||||
Just budgetSpan -> do
|
txs <- combineError (concat <$> res1) res2 (++)
|
||||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
m <- askDBState kmCurrency
|
||||||
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
|
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
||||||
let res2 = expandTransfers c budgetSpan bgtTransfers
|
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
|
||||||
combineErrorM (concat <$> res1) res2 $ \is ts ->
|
|
||||||
addShadowTransfers bgtShadowTransfers (is ++ ts)
|
|
||||||
where
|
where
|
||||||
c = CommitR (CommitHash $ hash b) CTBudget
|
|
||||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||||
pre_ = sortAllos bgtPretax
|
pre_ = sortAllos bgtPretax
|
||||||
|
@ -52,15 +58,73 @@ readBudget
|
||||||
(alloAcnt <$> bgtPretax)
|
(alloAcnt <$> bgtPretax)
|
||||||
++ (alloAcnt <$> bgtTax)
|
++ (alloAcnt <$> bgtTax)
|
||||||
++ (alloAcnt <$> bgtPosttax)
|
++ (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
|
sortAllo a@Allocation {alloAmts = as} = do
|
||||||
bs <- foldSpan [] $ L.sortOn amtWhen as
|
bs <- foldSpan [] $ L.sortOn amtWhen as
|
||||||
return $ a {alloAmts = reverse bs}
|
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
|
-- TODO this will scan the interval allocations fully each time
|
||||||
-- iteration which is a total waste, but the fix requires turning this
|
-- iteration which is a total waste, but the fix requires turning this
|
||||||
-- loop into a fold which I don't feel like doing now :(
|
-- loop into a fold which I don't feel like doing now :(
|
||||||
readIncome
|
insertIncome
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> CommitR
|
=> CommitRId
|
||||||
|
-> T.Text
|
||||||
-> IntAllocations
|
-> IntAllocations
|
||||||
-> DaySpan
|
-> Maybe Interval
|
||||||
-> Income
|
-> Income
|
||||||
-> m [Tx CommitR]
|
-> m [UnbalancedTransfer]
|
||||||
readIncome
|
insertIncome
|
||||||
key
|
key
|
||||||
|
name
|
||||||
(intPre, intTax, intPost)
|
(intPre, intTax, intPost)
|
||||||
ds
|
localInterval
|
||||||
Income
|
Income
|
||||||
{ incWhen
|
{ incWhen
|
||||||
, incCurrency
|
, incCurrency
|
||||||
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
|
, incFrom
|
||||||
, incPretax
|
, incPretax
|
||||||
, incPosttax
|
, incPosttax
|
||||||
, incTaxes
|
, incTaxes
|
||||||
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
|
, incToBal
|
||||||
, incGross
|
, incGross
|
||||||
, incPayPeriod
|
, incPayPeriod
|
||||||
, incPriority
|
|
||||||
} =
|
} =
|
||||||
combineErrorM
|
combineErrorM
|
||||||
(combineError incRes nonIncRes (,))
|
(combineError incRes nonIncRes (,))
|
||||||
(combineError cpRes dayRes (,))
|
(combineError precRes dayRes (,))
|
||||||
$ \_ (cp, days) -> do
|
$ \_ (precision, days) -> do
|
||||||
let gross = realFracToDecimalP (cpPrec cp) incGross
|
let gross = roundPrecision precision incGross
|
||||||
foldDays (allocate cp gross) start days
|
concat <$> foldDays (allocate precision gross) start days
|
||||||
where
|
where
|
||||||
srcAcnt' = AcntID srcAcnt
|
incRes = isIncomeAcnt $ taAcnt incFrom
|
||||||
destAcnt' = AcntID destAcnt
|
|
||||||
incRes = isIncomeAcnt srcAcnt'
|
|
||||||
nonIncRes =
|
nonIncRes =
|
||||||
mapErrors isNotIncomeAcnt $
|
mapErrors isNotIncomeAcnt $
|
||||||
destAcnt'
|
taAcnt incToBal
|
||||||
: (alloAcnt <$> incPretax)
|
: (alloAcnt <$> incPretax)
|
||||||
++ (alloAcnt <$> incTaxes)
|
++ (alloAcnt <$> incTaxes)
|
||||||
++ (alloAcnt <$> incPosttax)
|
++ (alloAcnt <$> incPosttax)
|
||||||
cpRes = lookupCurrency incCurrency
|
precRes = lookupCurrencyPrec incCurrency
|
||||||
dayRes = liftExcept $ expandDatePat ds incWhen
|
dayRes = askDays incWhen localInterval
|
||||||
start = fromGregorian' $ pStart incPayPeriod
|
start = fromGregorian' $ pStart incPayPeriod
|
||||||
pType' = pType incPayPeriod
|
pType' = pType incPayPeriod
|
||||||
|
meta = BudgetMeta key name
|
||||||
flatPre = concatMap flattenAllo incPretax
|
flatPre = concatMap flattenAllo incPretax
|
||||||
flatTax = concatMap flattenAllo incTaxes
|
flatTax = concatMap flattenAllo incTaxes
|
||||||
flatPost = concatMap flattenAllo incPosttax
|
flatPost = concatMap flattenAllo incPosttax
|
||||||
sumAllos = sum . fmap faValue
|
sumAllos = sum . fmap faValue
|
||||||
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
|
-- TODO ensure these are all the "correct" accounts
|
||||||
allocate cp gross prevDay day = do
|
allocate precision gross prevDay day = do
|
||||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||||
let precision = cpPrec cp
|
|
||||||
let (preDeductions, pre) =
|
let (preDeductions, pre) =
|
||||||
allocatePre precision gross $
|
allocatePre precision gross $
|
||||||
flatPre ++ concatMap (selectAllos day) intPre
|
flatPre ++ concatMap (selectAllos day) intPre
|
||||||
let tax =
|
tax =
|
||||||
allocateTax precision gross preDeductions scaler $
|
allocateTax precision gross preDeductions scaler $
|
||||||
flatTax ++ concatMap (selectAllos day) intTax
|
flatTax ++ concatMap (selectAllos day) intTax
|
||||||
aftertaxGross = gross - sumAllos (tax ++ pre)
|
aftertaxGross = gross - sumAllos (tax ++ pre)
|
||||||
let post =
|
post =
|
||||||
allocatePost precision aftertaxGross $
|
allocatePost precision aftertaxGross $
|
||||||
flatPost ++ concatMap (selectAllos day) intPost
|
flatPost ++ concatMap (selectAllos day) intPost
|
||||||
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
|
balance = aftertaxGross - sumAllos post
|
||||||
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
|
bal =
|
||||||
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
FlatTransfer
|
||||||
let primary =
|
{ ftMeta = meta
|
||||||
EntrySet
|
, ftWhen = day
|
||||||
{ esTotalValue = -gross
|
, ftFrom = incFrom
|
||||||
, esCurrency = cpID cp
|
, ftCur = NoX incCurrency
|
||||||
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
|
, ftTo = incToBal
|
||||||
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
|
, ftValue = UnbalancedValue BTFixed balance
|
||||||
|
, ftDesc = "balance after deductions"
|
||||||
}
|
}
|
||||||
return $
|
in if balance < 0
|
||||||
Tx
|
then throwError $ InsertException [IncomeError day name balance]
|
||||||
{ txMeta = TxMeta day incPriority (TxDesc "") key
|
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
||||||
, txPrimary = Left primary
|
|
||||||
, txOther = []
|
|
||||||
}
|
|
||||||
|
|
||||||
periodScaler
|
periodScaler
|
||||||
:: PeriodType
|
:: PeriodType
|
||||||
-> Day
|
-> Day
|
||||||
-> Day
|
-> Day
|
||||||
-> AppExcept PeriodScaler
|
-> InsertExcept PeriodScaler
|
||||||
periodScaler pt prev cur = return scale
|
periodScaler pt prev cur = return scale
|
||||||
where
|
where
|
||||||
n = workingDays wds prev cur
|
n = fromIntegral $ workingDays wds prev cur
|
||||||
wds = case pt of
|
wds = case pt of
|
||||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||||
Daily ds -> ds
|
Daily ds -> ds
|
||||||
scale prec x = case pt of
|
scale precision x = case pt of
|
||||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||||
realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
|
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
||||||
* fromIntegral hpDailyHours
|
* fromIntegral hpDailyHours
|
||||||
* fromIntegral n
|
* n
|
||||||
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
|
Daily _ -> x * n / 365.25
|
||||||
|
where
|
||||||
|
rnd = roundPrecision precision
|
||||||
|
|
||||||
-- ASSUME start < end
|
-- ASSUME start < end
|
||||||
workingDays :: [Weekday] -> Day -> Day -> Natural
|
workingDays :: [Weekday] -> Day -> Day -> Natural
|
||||||
|
@ -189,7 +252,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
|
||||||
|
|
||||||
-- ASSUME days is a sorted list
|
-- ASSUME days is a sorted list
|
||||||
foldDays
|
foldDays
|
||||||
:: MonadAppError m
|
:: MonadInsertError m
|
||||||
=> (Day -> Day -> m a)
|
=> (Day -> Day -> m a)
|
||||||
-> Day
|
-> Day
|
||||||
-> [Day]
|
-> [Day]
|
||||||
|
@ -199,27 +262,27 @@ foldDays f start days = case NE.nonEmpty days of
|
||||||
Just ds
|
Just ds
|
||||||
| any (start >) ds ->
|
| any (start >) ds ->
|
||||||
throwError $
|
throwError $
|
||||||
AppException [PeriodError start $ minimum ds]
|
InsertException [PeriodError start $ minimum ds]
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
combineErrors $
|
combineErrors $
|
||||||
snd $
|
snd $
|
||||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
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
|
isIncomeAcnt = checkAcntType IncomeT
|
||||||
|
|
||||||
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
|
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
||||||
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
||||||
|
|
||||||
checkAcntType
|
checkAcntType
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> AcntType
|
=> AcntType
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> m ()
|
-> m ()
|
||||||
checkAcntType t = checkAcntTypes (t :| [])
|
checkAcntType t = checkAcntTypes (t :| [])
|
||||||
|
|
||||||
checkAcntTypes
|
checkAcntTypes
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> NE.NonEmpty AcntType
|
=> NE.NonEmpty AcntType
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> m ()
|
-> m ()
|
||||||
|
@ -227,70 +290,83 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
|
||||||
where
|
where
|
||||||
go t
|
go t
|
||||||
| t `L.elem` ts = return i
|
| t `L.elem` ts = return i
|
||||||
| otherwise = throwError $ AppException [AccountTypeError i ts]
|
| otherwise = throwError $ InsertException [AccountError i ts]
|
||||||
|
|
||||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||||
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
|
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
||||||
where
|
where
|
||||||
go Amount {amtValue, amtDesc} =
|
go Amount {amtValue, amtDesc} =
|
||||||
FlatAllocation
|
FlatAllocation
|
||||||
{ faTo = alloTo
|
{ faCur = NoX alloCur
|
||||||
|
, faTo = alloTo
|
||||||
, faValue = amtValue
|
, faValue = amtValue
|
||||||
, faDesc = amtDesc
|
, faDesc = amtDesc
|
||||||
}
|
}
|
||||||
|
|
||||||
-- ASSUME allocations are sorted
|
-- ASSUME allocations are sorted
|
||||||
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
||||||
selectAllos day Allocation {alloAmts, alloTo} =
|
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
||||||
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
||||||
where
|
where
|
||||||
go Amount {amtValue, amtDesc} =
|
go Amount {amtValue, amtDesc} =
|
||||||
FlatAllocation
|
FlatAllocation
|
||||||
{ faTo = alloTo
|
{ faCur = NoX alloCur
|
||||||
|
, faTo = alloTo
|
||||||
, faValue = amtValue
|
, faValue = amtValue
|
||||||
, faDesc = amtDesc
|
, faDesc = amtDesc
|
||||||
}
|
}
|
||||||
|
|
||||||
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
|
allo2Trans
|
||||||
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
|
:: BudgetMeta
|
||||||
Entry
|
-> Day
|
||||||
{ eValue = LinkValue (EntryFixed faValue)
|
-> TaggedAcnt
|
||||||
, eComment = faDesc
|
-> FlatAllocation Rational
|
||||||
, eAcnt = AcntID taAcnt
|
-> UnbalancedTransfer
|
||||||
, eTags = TagID <$> taTags
|
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
|
allocatePre
|
||||||
:: Precision
|
:: Natural
|
||||||
-> Decimal
|
-> Rational
|
||||||
-> [FlatAllocation PretaxValue]
|
-> [FlatAllocation PretaxValue]
|
||||||
-> (PreDeductions, [FlatAllocation Decimal])
|
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||||
allocatePre precision gross = L.mapAccumR go M.empty
|
allocatePre precision gross = L.mapAccumR go M.empty
|
||||||
where
|
where
|
||||||
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
|
go m f@FlatAllocation {faValue} =
|
||||||
let v =
|
let c = preCategory faValue
|
||||||
if prePercent
|
p = preValue faValue
|
||||||
then gross *. (preValue / 100)
|
v =
|
||||||
else realFracToDecimalP precision preValue
|
if prePercent faValue
|
||||||
in (mapAdd_ preCategory v m, f {faValue = v})
|
then (roundPrecision 3 p / 100) * gross
|
||||||
|
else roundPrecision precision p
|
||||||
|
in (mapAdd_ c v m, f {faValue = v})
|
||||||
|
|
||||||
allocateTax
|
allocateTax
|
||||||
:: Precision
|
:: Natural
|
||||||
-> Decimal
|
-> Rational
|
||||||
-> PreDeductions
|
-> M.Map T.Text Rational
|
||||||
-> PeriodScaler
|
-> PeriodScaler
|
||||||
-> [FlatAllocation TaxValue]
|
-> [FlatAllocation TaxValue]
|
||||||
-> [FlatAllocation Decimal]
|
-> [FlatAllocation Rational]
|
||||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||||
where
|
where
|
||||||
go TaxValue {tvCategories, tvMethod} =
|
go TaxValue {tvCategories, tvMethod} =
|
||||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||||
in case tvMethod of
|
in case tvMethod of
|
||||||
TMPercent p -> agi *. p / 100
|
TMPercent p ->
|
||||||
|
roundPrecision precision $
|
||||||
|
fromRational $
|
||||||
|
roundPrecision 3 p / 100 * agi
|
||||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||||
let taxDed = f precision tpDeductible
|
let taxDed = roundPrecision precision $ f precision tpDeductible
|
||||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||||
|
|
||||||
-- | Compute effective tax percentage of a bracket
|
-- | 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
|
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||||
-- three steps are implemented from this alone.
|
-- three steps are implemented from this alone.
|
||||||
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
|
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
||||||
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||||
where
|
where
|
||||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||||
let l = f prec tbLowerLimit
|
let l = roundPrecision precision $ f precision tbLowerLimit
|
||||||
in if remain >= l
|
p = roundPrecision 3 tbPercent / 100
|
||||||
then (acc + (remain - l) *. (tbPercent / 100), l)
|
in if remain >= l then (acc + p * (remain - l), l) else a
|
||||||
else a
|
|
||||||
|
|
||||||
allocatePost
|
allocatePost
|
||||||
:: Precision
|
:: Natural
|
||||||
-> Decimal
|
-> Rational
|
||||||
-> [FlatAllocation PosttaxValue]
|
-> [FlatAllocation PosttaxValue]
|
||||||
-> [FlatAllocation Decimal]
|
-> [FlatAllocation Rational]
|
||||||
allocatePost prec aftertax = fmap (fmap go)
|
allocatePost precision aftertax = fmap (fmap go)
|
||||||
where
|
where
|
||||||
go PosttaxValue {postValue, postPercent}
|
go PosttaxValue {postValue, postPercent} =
|
||||||
| postPercent = aftertax *. (postValue / 100)
|
let v = postValue
|
||||||
| otherwise = realFracToDecimalP prec 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
|
-- shadow transfers
|
||||||
|
|
||||||
-- TODO this is going to be O(n*m), which might be a problem?
|
-- TODO this is going to be O(n*m), which might be a problem?
|
||||||
addShadowTransfers
|
addShadowTransfers
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: CurrencyMap
|
||||||
=> [ShadowTransfer]
|
-> [ShadowTransfer]
|
||||||
-> [Tx CommitR]
|
-> [UnbalancedTransfer]
|
||||||
-> m [Tx CommitR]
|
-> InsertExcept [UnbalancedTransfer]
|
||||||
addShadowTransfers ms = mapErrors go
|
addShadowTransfers cm ms txs =
|
||||||
where
|
fmap catMaybes $
|
||||||
go tx = do
|
combineErrors $
|
||||||
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
fmap (uncurry (fromShadow cm)) $
|
||||||
return $ tx {txOther = Right <$> es}
|
[(t, m) | t <- txs, m <- ms]
|
||||||
|
|
||||||
fromShadow
|
fromShadow
|
||||||
:: (MonadAppError m, MonadFinance m)
|
:: CurrencyMap
|
||||||
=> Tx CommitR
|
-> UnbalancedTransfer
|
||||||
-> ShadowTransfer
|
-> ShadowTransfer
|
||||||
-> m (Maybe ShadowEntrySet)
|
-> InsertExcept (Maybe UnbalancedTransfer)
|
||||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
|
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
||||||
combineErrorM curRes mRes $ \cur compiled -> do
|
res <- shadowMatches (stMatch t) tx
|
||||||
res <- liftExcept $ shadowMatches compiled tx
|
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
|
||||||
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
return $
|
||||||
return $ if not res then Nothing else Just es
|
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
|
where
|
||||||
curRes = lookupCurrencyKey stCurrency
|
memberMaybe x AcntSet {asList, asInclude} =
|
||||||
mRes = liftExcept $ compileMatch stMatch
|
(if asInclude then id else not) $ x `elem` asList
|
||||||
|
|
||||||
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
|
|
||||||
return $
|
|
||||||
fromRes
|
|
||||||
&& toRes
|
|
||||||
&& maybe True (`dateMatches` txmDate) 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)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- random
|
-- random
|
||||||
|
|
||||||
|
initialCurrency :: BudgetCurrency -> CurID
|
||||||
|
initialCurrency (NoX c) = c
|
||||||
|
initialCurrency (X Exchange {xFromCur = c}) = c
|
||||||
|
|
||||||
alloAcnt :: Allocation w v -> AcntID
|
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 =
|
type IntAllocations =
|
||||||
( [DaySpanAllocation PretaxValue]
|
( [DaySpanAllocation PretaxValue]
|
||||||
|
@ -409,11 +557,14 @@ type IntAllocations =
|
||||||
|
|
||||||
type DaySpanAllocation = Allocation DaySpan
|
type DaySpanAllocation = Allocation DaySpan
|
||||||
|
|
||||||
type PeriodScaler = Precision -> Double -> Decimal
|
type EntryPair = (KeyEntry, KeyEntry)
|
||||||
|
|
||||||
|
type PeriodScaler = Natural -> Double -> Double
|
||||||
|
|
||||||
data FlatAllocation v = FlatAllocation
|
data FlatAllocation v = FlatAllocation
|
||||||
{ faValue :: !v
|
{ faValue :: !v
|
||||||
, faDesc :: !T.Text
|
, faDesc :: !T.Text
|
||||||
, faTo :: !TaggedAcnt
|
, faTo :: !TaggedAcnt
|
||||||
|
, faCur :: !BudgetCurrency
|
||||||
}
|
}
|
||||||
deriving (Functor, Show)
|
deriving (Functor, Show)
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -1,17 +1,15 @@
|
||||||
module Internal.History
|
module Internal.History
|
||||||
( readHistStmt
|
( splitHistory
|
||||||
, readHistTransfer
|
, insertHistTransfer
|
||||||
, splitHistory
|
, readHistStmt
|
||||||
, readHistoryCRUD
|
, insertHistStmt
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Csv
|
import Data.Csv
|
||||||
import Data.Decimal
|
import Database.Persist.Monad
|
||||||
import Data.Foldable
|
import Internal.Database
|
||||||
import Data.Hashable
|
|
||||||
import GHC.Real
|
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
|
@ -22,73 +20,107 @@ import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
import qualified RIO.Vector as V
|
import qualified RIO.Vector as V
|
||||||
import Text.Regex.TDFA hiding (matchAll)
|
|
||||||
|
|
||||||
readHistoryCRUD
|
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||||
:: (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 = partitionEithers . fmap go
|
splitHistory = partitionEithers . fmap go
|
||||||
where
|
where
|
||||||
go (HistTransfer x) = Left x
|
go (HistTransfer x) = Left x
|
||||||
go (HistStatement x) = Right x
|
go (HistStatement x) = Right x
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
insertHistTransfer
|
||||||
-- Transfers
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
=> HistTransfer
|
||||||
readHistTransfer
|
-> m ()
|
||||||
:: (MonadAppError m, MonadFinance m)
|
insertHistTransfer
|
||||||
=> PairedTransfer
|
m@Transfer
|
||||||
-> m [Tx CommitR]
|
{ transFrom = from
|
||||||
readHistTransfer ht = do
|
, transTo = to
|
||||||
bounds <- asks (unHSpan . tsHistoryScope)
|
, transCurrency = u
|
||||||
expandTransfer c bounds ht
|
, transAmounts = amts
|
||||||
where
|
} = do
|
||||||
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
whenHash CTManual m () $ \c -> do
|
||||||
|
bounds <- askDBState kmStatementInterval
|
||||||
--------------------------------------------------------------------------------
|
let precRes = lookupCurrencyPrec u
|
||||||
-- Statements
|
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
|
readHistStmt
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> Statement
|
-> Statement
|
||||||
-> m (Either AppException [Tx CommitR])
|
-> m (Maybe (CommitR, [KeyTx]))
|
||||||
readHistStmt root i = do
|
readHistStmt root i = whenHash_ CTImport i $ do
|
||||||
bounds <- asks (unHSpan . tsHistoryScope)
|
|
||||||
bs <- readImport root i
|
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
|
where
|
||||||
go t@Tx {txMeta = m} =
|
split a v =
|
||||||
t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
|
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?)
|
-- TODO this probably won't scale well (pipes?)
|
||||||
readImport
|
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
|
||||||
=> FilePath
|
|
||||||
-> Statement
|
|
||||||
-> m (Either AppException [Tx ()])
|
|
||||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||||
let ores = compileOptions stmtTxOpts
|
let ores = compileOptions stmtTxOpts
|
||||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||||
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
||||||
runExceptT (matchRecords compiledMatches records)
|
m <- askDBState kmCurrency
|
||||||
|
fromEither $
|
||||||
|
flip runReader m $
|
||||||
|
runExceptT $
|
||||||
|
matchRecords compiledMatches records
|
||||||
where
|
where
|
||||||
paths = (root </>) <$> stmtPaths
|
paths = (root </>) <$> stmtPaths
|
||||||
|
|
||||||
|
@ -101,9 +133,9 @@ readImport_
|
||||||
-> m [TxRecord]
|
-> m [TxRecord]
|
||||||
readImport_ n delim tns p = do
|
readImport_ n delim tns p = do
|
||||||
res <- tryIO $ BL.readFile p
|
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
|
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
|
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||||
where
|
where
|
||||||
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
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
|
-- 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
|
-- blank dates but will likely want to make this more flexible
|
||||||
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
||||||
parseTxRecord
|
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
|
||||||
p
|
d <- r .: T.encodeUtf8 toDate
|
||||||
TxOpts
|
if d == ""
|
||||||
{ toDate
|
then return Nothing
|
||||||
, toDesc
|
else do
|
||||||
, toAmount
|
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||||
, toOther
|
e <- r .: T.encodeUtf8 toDesc
|
||||||
, toDateFmt
|
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||||
, toSkipBlankDate
|
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||||
, toSkipBlankAmount
|
return $ Just $ TxRecord d' a e os p
|
||||||
, 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)
|
|
||||||
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
|
|
||||||
|
|
||||||
matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
|
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
|
||||||
matchRecords ms rs = do
|
matchRecords ms rs = do
|
||||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||||
case (matched, unmatched, notfound) of
|
case (matched, unmatched, notfound) of
|
||||||
(ms_, [], []) -> return ms_
|
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||||
(_, us, ns) -> throwError $ AppException [StatementError us ns]
|
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||||
|
|
||||||
matchPriorities :: [StatementParserRe] -> [MatchGroup]
|
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||||
matchPriorities =
|
matchPriorities =
|
||||||
fmap matchToGroup
|
fmap matchToGroup
|
||||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||||
. L.sortOn (Down . spPriority)
|
. L.sortOn (Down . spPriority)
|
||||||
|
|
||||||
matchToGroup :: [StatementParserRe] -> MatchGroup
|
matchToGroup :: [MatchRe] -> MatchGroup
|
||||||
matchToGroup ms =
|
matchToGroup ms =
|
||||||
uncurry MatchGroup $
|
uncurry MatchGroup $
|
||||||
first (L.sortOn spDate) $
|
first (L.sortOn spDate) $
|
||||||
L.partition (isJust . spDate) ms
|
L.partition (isJust . spDate) ms
|
||||||
|
|
||||||
data MatchGroup = MatchGroup
|
data MatchGroup = MatchGroup
|
||||||
{ mgDate :: ![StatementParserRe]
|
{ mgDate :: ![MatchRe]
|
||||||
, mgNoDate :: ![StatementParserRe]
|
, mgNoDate :: ![MatchRe]
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
@ -236,10 +214,9 @@ zipperSlice f x = go
|
||||||
LT -> z
|
LT -> z
|
||||||
|
|
||||||
zipperMatch
|
zipperMatch
|
||||||
:: MonadFinance m
|
:: Unzipped MatchRe
|
||||||
=> Unzipped StatementParserRe
|
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
|
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
where
|
where
|
||||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
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)
|
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||||
|
|
||||||
zipperMatch'
|
zipperMatch'
|
||||||
:: MonadFinance m
|
:: Zipped MatchRe
|
||||||
=> Zipped StatementParserRe
|
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
|
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||||
zipperMatch' z x = go z
|
zipperMatch' z x = go z
|
||||||
where
|
where
|
||||||
go (Zipped bs (a : as)) = do
|
go (Zipped bs (a : as)) = do
|
||||||
|
@ -267,17 +243,13 @@ zipperMatch' z x = go z
|
||||||
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||||
go z' = return (z', MatchFail)
|
go z' = return (z', MatchFail)
|
||||||
|
|
||||||
matchDec :: StatementParserRe -> Maybe StatementParserRe
|
matchDec :: MatchRe -> Maybe MatchRe
|
||||||
matchDec m = case spTimes m of
|
matchDec m = case spTimes m of
|
||||||
Just 1 -> Nothing
|
Just 1 -> Nothing
|
||||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||||
Nothing -> Just m
|
Nothing -> Just m
|
||||||
|
|
||||||
matchAll
|
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||||
:: MonadFinance m
|
|
||||||
=> [MatchGroup]
|
|
||||||
-> [TxRecord]
|
|
||||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
|
||||||
matchAll = go ([], [])
|
matchAll = go ([], [])
|
||||||
where
|
where
|
||||||
go (matched, unused) gs rs = case (gs, rs) of
|
go (matched, unused) gs rs = case (gs, rs) of
|
||||||
|
@ -287,21 +259,13 @@ matchAll = go ([], [])
|
||||||
(ts, unmatched, us) <- matchGroup g rs
|
(ts, unmatched, us) <- matchGroup g rs
|
||||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||||
|
|
||||||
matchGroup
|
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||||
:: MonadFinance m
|
|
||||||
=> MatchGroup
|
|
||||||
-> [TxRecord]
|
|
||||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
|
||||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||||
(md, rest, ud) <- matchDates ds rs
|
(md, rest, ud) <- matchDates ds rs
|
||||||
(mn, unmatched, un) <- matchNonDates ns rest
|
(mn, unmatched, un) <- matchNonDates ns rest
|
||||||
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||||
|
|
||||||
matchDates
|
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||||
:: MonadFinance m
|
|
||||||
=> [StatementParserRe]
|
|
||||||
-> [TxRecord]
|
|
||||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
|
||||||
matchDates ms = go ([], [], initZipper ms)
|
matchDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] =
|
go (matched, unmatched, z) [] =
|
||||||
|
@ -322,11 +286,7 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
go (m, u, z') rs
|
go (m, u, z') rs
|
||||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||||
|
|
||||||
matchNonDates
|
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||||
:: MonadFinance m
|
|
||||||
=> [StatementParserRe]
|
|
||||||
-> [TxRecord]
|
|
||||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
|
||||||
matchNonDates ms = go ([], [], initZipper ms)
|
matchNonDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] =
|
go (matched, unmatched, z) [] =
|
||||||
|
@ -343,225 +303,26 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
MatchFail -> (matched, r : unmatched)
|
MatchFail -> (matched, r : unmatched)
|
||||||
in go (m, u, resetZipper z') rs
|
in go (m, u, resetZipper z') rs
|
||||||
|
|
||||||
matches
|
balanceTx :: RawTx -> InsertExcept BalTx
|
||||||
:: MonadFinance m
|
balanceTx t@Tx {txEntries = ss} = do
|
||||||
=> StatementParserRe
|
bs <- balanceEntries ss
|
||||||
-> TxRecord
|
return $ t {txEntries = bs}
|
||||||
-> 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
|
|
||||||
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
|
|
||||||
|
|
||||||
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
|
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||||
toTx
|
balanceEntries ss =
|
||||||
priority
|
fmap concat
|
||||||
TxGetter
|
<$> mapM (uncurry bal)
|
||||||
{ tgFrom
|
$ groupByKey
|
||||||
, tgTo
|
$ fmap (\s -> (eCurrency s, s)) ss
|
||||||
, 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
|
where
|
||||||
acntRes = resolveAcnt r thgAcnt
|
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||||
esRes = mapErrors (resolveEntry f prec r) thgEntries
|
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]
|
||||||
|
|
||||||
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept Bool
|
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
||||||
otherMatches dict m = case m of
|
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
||||||
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
|
|
||||||
|
|
|
@ -7,12 +7,9 @@
|
||||||
-- | Types corresponding to the database model
|
-- | Types corresponding to the database model
|
||||||
module Internal.Types.Database where
|
module Internal.Types.Database where
|
||||||
|
|
||||||
import Data.Csv (FromField)
|
|
||||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||||
import Database.Persist.TH
|
import Database.Persist.TH
|
||||||
import Internal.Types.Dhall
|
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.NonEmpty as NE
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
|
@ -20,106 +17,51 @@ share
|
||||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||||
[persistLowerCase|
|
[persistLowerCase|
|
||||||
CommitR sql=commits
|
CommitR sql=commits
|
||||||
hash CommitHash
|
hash Int
|
||||||
type ConfigType
|
type ConfigType
|
||||||
UniqueCommitHash hash
|
deriving Show Eq
|
||||||
deriving Show Eq Ord
|
|
||||||
|
|
||||||
ConfigStateR sql=config_state
|
|
||||||
historySpan HistorySpan
|
|
||||||
budgetSpan BudgetSpan
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
CurrencyR sql=currencies
|
CurrencyR sql=currencies
|
||||||
symbol CurID
|
symbol T.Text
|
||||||
fullname T.Text
|
fullname T.Text
|
||||||
precision Precision
|
precision Int
|
||||||
UniqueCurrencySymbol symbol
|
deriving Show Eq
|
||||||
UniqueCurrencyFullname fullname
|
|
||||||
deriving Show Eq Ord
|
|
||||||
|
|
||||||
TagR sql=tags
|
TagR sql=tags
|
||||||
symbol TagID
|
symbol T.Text
|
||||||
fullname T.Text
|
fullname T.Text
|
||||||
UniqueTagSymbol symbol
|
deriving Show Eq
|
||||||
UniqueTagFullname fullname
|
|
||||||
deriving Show Eq Ord
|
|
||||||
|
|
||||||
AccountR sql=accounts
|
AccountR sql=accounts
|
||||||
name T.Text
|
name T.Text
|
||||||
fullpath AcntPath
|
fullpath T.Text
|
||||||
desc T.Text
|
desc T.Text
|
||||||
sign AcntSign
|
deriving Show Eq
|
||||||
leaf Bool
|
|
||||||
UniqueAccountFullpath fullpath
|
|
||||||
deriving Show Eq Ord
|
|
||||||
|
|
||||||
AccountPathR sql=account_paths
|
AccountPathR sql=account_paths
|
||||||
parent AccountRId
|
parent AccountRId OnDeleteCascade
|
||||||
child AccountRId
|
child AccountRId OnDeleteCascade
|
||||||
depth Int
|
depth Int
|
||||||
deriving Show Eq Ord
|
deriving Show Eq
|
||||||
|
|
||||||
TransactionR sql=transactions
|
TransactionR sql=transactions
|
||||||
commit CommitRId
|
commit CommitRId OnDeleteCascade
|
||||||
date Day
|
date Day
|
||||||
budgetName BudgetName
|
description T.Text
|
||||||
description TxDesc
|
|
||||||
priority Int
|
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|
|
||||||
EntrySetR sql=entry_sets
|
|
||||||
transaction TransactionRId
|
|
||||||
currency CurrencyRId
|
|
||||||
index EntrySetIndex
|
|
||||||
rebalance Bool
|
|
||||||
deriving Show Eq
|
|
||||||
|
|
||||||
EntryR sql=entries
|
EntryR sql=entries
|
||||||
entryset EntrySetRId
|
transaction TransactionRId OnDeleteCascade
|
||||||
account AccountRId
|
currency CurrencyRId OnDeleteCascade
|
||||||
|
account AccountRId OnDeleteCascade
|
||||||
memo T.Text
|
memo T.Text
|
||||||
value Rational
|
value Rational
|
||||||
index EntryIndex
|
|
||||||
cachedValue (Maybe Rational)
|
|
||||||
cachedType (Maybe TransferType)
|
|
||||||
cachedLink (Maybe EntryIndex)
|
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|
|
||||||
TagRelationR sql=tag_relations
|
TagRelationR sql=tag_relations
|
||||||
entry EntryRId
|
entry EntryRId OnDeleteCascade
|
||||||
tag TagRId
|
tag TagRId OnDeleteCascade
|
||||||
|
BudgetLabelR sql=budget_labels
|
||||||
|
entry EntryRId OnDeleteCascade
|
||||||
|
budgetName T.Text
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|]
|
|]
|
||||||
|
|
||||||
newtype TxIndex = TxIndex {unTxIndex :: Int}
|
data ConfigType = CTBudget | CTManual | CTImport
|
||||||
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
|
deriving (Eq, Show, Read, Enum)
|
||||||
|
|
||||||
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)
|
|
||||||
|
|
||||||
instance PersistFieldSql ConfigType where
|
instance PersistFieldSql ConfigType where
|
||||||
sqlType _ = SqlString
|
sqlType _ = SqlString
|
||||||
|
@ -127,61 +69,7 @@ instance PersistFieldSql ConfigType where
|
||||||
instance PersistField ConfigType where
|
instance PersistField ConfigType where
|
||||||
toPersistValue = PersistText . T.pack . show
|
toPersistValue = PersistText . T.pack . show
|
||||||
|
|
||||||
|
-- TODO these error messages *might* be good enough?
|
||||||
fromPersistValue (PersistText v) =
|
fromPersistValue (PersistText v) =
|
||||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||||
fromPersistValue _ = Left "not a string"
|
fromPersistValue _ = Left "wrong type"
|
||||||
|
|
||||||
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"
|
|
||||||
|
|
|
@ -19,9 +19,9 @@ import Language.Haskell.TH.Syntax (Lift)
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import RIO.Time
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
|
|
||||||
makeHaskellTypesWith
|
makeHaskellTypesWith
|
||||||
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
||||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||||
|
@ -33,14 +33,13 @@ makeHaskellTypesWith
|
||||||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||||
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
||||||
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
||||||
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
|
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||||
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
|
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
||||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||||
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
||||||
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
|
|
||||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||||
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
, 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 "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||||
|
@ -49,16 +48,12 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||||
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
||||||
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
|
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
|
||||||
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
|
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||||
, SingleConstructor
|
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
|
||||||
"Amount"
|
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||||
"Amount"
|
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
|
||||||
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
|
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
||||||
, SingleConstructor
|
|
||||||
"AcntMatcher_"
|
|
||||||
"AcntMatcher_"
|
|
||||||
"\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
|
|
||||||
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
||||||
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
||||||
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
||||||
|
@ -66,9 +61,14 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
|
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
|
||||||
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
|
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
|
||||||
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
|
, 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 "Period" "Period" "(./dhall/Types.dhall).Period"
|
||||||
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
|
, 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
|
deriveProduct
|
||||||
|
@ -87,13 +87,17 @@ deriveProduct
|
||||||
, "CronPat"
|
, "CronPat"
|
||||||
, "DatePat"
|
, "DatePat"
|
||||||
, "TaggedAcnt"
|
, "TaggedAcnt"
|
||||||
|
, "Budget"
|
||||||
, "Income"
|
, "Income"
|
||||||
|
, "ShadowTransfer"
|
||||||
|
, "TransferMatcher"
|
||||||
|
, "AcntSet"
|
||||||
, "DateMatcher"
|
, "DateMatcher"
|
||||||
, "ValMatcher"
|
, "ValMatcher"
|
||||||
, "YMDMatcher"
|
, "YMDMatcher"
|
||||||
|
, "BudgetCurrency"
|
||||||
|
, "Exchange"
|
||||||
, "EntryNumGetter"
|
, "EntryNumGetter"
|
||||||
, "LinkedNumGetter"
|
|
||||||
, "LinkedEntryNumGetter"
|
|
||||||
, "TemporalScope"
|
, "TemporalScope"
|
||||||
, "SqlConfig"
|
, "SqlConfig"
|
||||||
, "PretaxValue"
|
, "PretaxValue"
|
||||||
|
@ -102,8 +106,8 @@ deriveProduct
|
||||||
, "TaxProgression"
|
, "TaxProgression"
|
||||||
, "TaxMethod"
|
, "TaxMethod"
|
||||||
, "PosttaxValue"
|
, "PosttaxValue"
|
||||||
, "TransferValue"
|
, "BudgetTransferValue"
|
||||||
, "TransferType"
|
, "BudgetTransferType"
|
||||||
, "Period"
|
, "Period"
|
||||||
, "PeriodType"
|
, "PeriodType"
|
||||||
, "HourlyPeriod"
|
, "HourlyPeriod"
|
||||||
|
@ -174,45 +178,25 @@ deriving instance Ord DatePat
|
||||||
|
|
||||||
deriving instance Hashable 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
|
deriving instance FromDhall BudgetTransfer
|
||||||
|
|
||||||
newtype BudgetName = BudgetName {unBudgetName :: T.Text}
|
|
||||||
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
|
||||||
|
|
||||||
data Budget = Budget
|
data Budget = Budget
|
||||||
{ bgtLabel :: !BudgetName
|
{ bgtLabel :: Text
|
||||||
, bgtIncomes :: ![Income]
|
, bgtIncomes :: [Income]
|
||||||
, bgtPretax :: ![MultiAllocation PretaxValue]
|
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||||
, bgtTax :: ![MultiAllocation TaxValue]
|
, bgtTax :: [MultiAllocation TaxValue]
|
||||||
, bgtPosttax :: ![MultiAllocation PosttaxValue]
|
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||||
, bgtTransfers :: ![PairedTransfer]
|
, bgtTransfers :: [BudgetTransfer]
|
||||||
, bgtShadowTransfers :: ![ShadowTransfer]
|
, bgtShadowTransfers :: [ShadowTransfer]
|
||||||
, bgtInterval :: !(Maybe Interval)
|
, 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
|
deriving instance Hashable PretaxValue
|
||||||
|
|
||||||
|
@ -226,28 +210,17 @@ deriving instance Hashable TaxValue
|
||||||
|
|
||||||
deriving instance Hashable PosttaxValue
|
deriving instance Hashable PosttaxValue
|
||||||
|
|
||||||
deriving instance Hashable TransferValue
|
deriving instance Hashable Budget
|
||||||
|
|
||||||
deriving instance Hashable TransferType
|
deriving instance Hashable BudgetTransferValue
|
||||||
|
|
||||||
deriving instance Read TransferType
|
deriving instance Hashable BudgetTransferType
|
||||||
|
|
||||||
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 TaggedAcnt
|
deriving instance Hashable TaggedAcnt
|
||||||
|
|
||||||
deriving instance Ord TaggedAcnt
|
deriving instance Ord TaggedAcnt
|
||||||
|
|
||||||
newtype CurID = CurID {unCurID :: T.Text}
|
type CurID = T.Text
|
||||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
|
||||||
|
|
||||||
data Income = Income
|
data Income = Income
|
||||||
{ incGross :: Double
|
{ incGross :: Double
|
||||||
|
@ -259,7 +232,6 @@ data Income = Income
|
||||||
, incFrom :: TaggedAcnt
|
, incFrom :: TaggedAcnt
|
||||||
, incToBal :: TaggedAcnt
|
, incToBal :: TaggedAcnt
|
||||||
, incPayPeriod :: !Period
|
, incPayPeriod :: !Period
|
||||||
, incPriority :: !Int
|
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving instance Hashable HourlyPeriod
|
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 (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 (Show w, Show v) => Show (Amount w v)
|
||||||
|
|
||||||
deriving instance (Eq w, Eq v) => Eq (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
|
data Allocation w v = Allocation
|
||||||
{ alloTo :: TaggedAcnt
|
{ alloTo :: TaggedAcnt
|
||||||
, alloAmts :: [Amount w v]
|
, alloAmts :: [Amount w v]
|
||||||
|
, alloCur :: CurID
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic, Hashable)
|
deriving (Eq, Show, Generic, Hashable)
|
||||||
|
|
||||||
|
@ -325,17 +304,11 @@ data Transfer a c w v = Transfer
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
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 Hashable TransferMatcher
|
||||||
|
|
||||||
deriving instance Generic (AcntMatcher_ Text)
|
|
||||||
|
|
||||||
deriving instance Hashable (AcntMatcher_ Text)
|
|
||||||
|
|
||||||
deriving instance FromDhall (AcntMatcher_ Text)
|
|
||||||
|
|
||||||
deriving instance Hashable ValMatcher
|
deriving instance Hashable ValMatcher
|
||||||
|
|
||||||
|
@ -367,10 +340,6 @@ instance Ord DateMatcher where
|
||||||
|
|
||||||
deriving instance Hashable EntryNumGetter
|
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
|
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||||
-- account tree type
|
-- account tree type
|
||||||
|
@ -393,7 +362,7 @@ data AccountRoot_ a = AccountRoot_
|
||||||
, arIncome :: ![a]
|
, arIncome :: ![a]
|
||||||
, arLiabilities :: ![a]
|
, arLiabilities :: ![a]
|
||||||
}
|
}
|
||||||
deriving (Generic, Hashable)
|
deriving (Generic)
|
||||||
|
|
||||||
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
||||||
|
|
||||||
|
@ -402,8 +371,10 @@ deriving instance FromDhall AccountRootF
|
||||||
type AccountRoot = AccountRoot_ AccountTree
|
type AccountRoot = AccountRoot_ AccountTree
|
||||||
|
|
||||||
data Config_ a = Config_
|
data Config_ a = Config_
|
||||||
{ scope :: !TemporalScope
|
{ global :: !TemporalScope
|
||||||
|
, budget :: ![Budget]
|
||||||
, currencies :: ![Currency]
|
, currencies :: ![Currency]
|
||||||
|
, statements :: ![History]
|
||||||
, accounts :: !a
|
, accounts :: !a
|
||||||
, tags :: ![Tag]
|
, tags :: ![Tag]
|
||||||
, sqlConfig :: !SqlConfig
|
, sqlConfig :: !SqlConfig
|
||||||
|
@ -433,76 +404,55 @@ instance FromDhall a => FromDhall (Config_ a)
|
||||||
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
||||||
|
|
||||||
-- TODO newtypes for these?
|
-- TODO newtypes for these?
|
||||||
newtype AcntID = AcntID {unAcntID :: T.Text}
|
type AcntID = T.Text
|
||||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
|
||||||
|
|
||||||
newtype TagID = TagID {unTagID :: T.Text}
|
type TagID = T.Text
|
||||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
|
||||||
|
type HistTransfer = Transfer AcntID CurID DatePat Double
|
||||||
|
|
||||||
|
deriving instance Generic HistTransfer
|
||||||
|
|
||||||
|
deriving instance Hashable HistTransfer
|
||||||
|
|
||||||
|
deriving instance FromDhall HistTransfer
|
||||||
|
|
||||||
data History
|
data History
|
||||||
= HistTransfer !PairedTransfer
|
= HistTransfer !HistTransfer
|
||||||
| HistStatement !Statement
|
| HistStatement !Statement
|
||||||
deriving (Eq, Generic, Hashable, FromDhall)
|
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)
|
data TxOpts re = TxOpts
|
||||||
|
{ toDate :: !T.Text
|
||||||
deriving instance Generic (TxOpts a)
|
, toAmount :: !T.Text
|
||||||
|
, toDesc :: !T.Text
|
||||||
deriving instance Hashable (TxOpts T.Text)
|
, toOther :: ![T.Text]
|
||||||
|
, toDateFmt :: !T.Text
|
||||||
deriving instance FromDhall (TxOpts T.Text)
|
, toAmountFmt :: !re
|
||||||
|
}
|
||||||
deriving instance Show a => Show (TxOpts a)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
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 Statement = Statement
|
data Statement = Statement
|
||||||
{ stmtPaths :: ![FilePath]
|
{ stmtPaths :: ![FilePath]
|
||||||
|
@ -511,30 +461,7 @@ data Statement = Statement
|
||||||
, stmtTxOpts :: !(TxOpts T.Text)
|
, stmtTxOpts :: !(TxOpts T.Text)
|
||||||
, stmtSkipLines :: !Natural
|
, stmtSkipLines :: !Natural
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall, Show)
|
deriving (Eq, Hashable, Generic, FromDhall)
|
||||||
|
|
||||||
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)
|
|
||||||
|
|
||||||
-- | the value of a field in entry (text version)
|
-- | the value of a field in entry (text version)
|
||||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
-- 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
|
| LookupT !T.Text
|
||||||
| MapT !(FieldMap T.Text t)
|
| MapT !(FieldMap T.Text t)
|
||||||
| Map2T !(FieldMap (T.Text, 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
|
type EntryCur = EntryTextGetter CurID
|
||||||
|
|
||||||
|
@ -576,32 +503,10 @@ data FieldMatcher re
|
||||||
|
|
||||||
deriving instance Show (FieldMatcher T.Text)
|
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
|
data TxGetter = TxGetter
|
||||||
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
|
{ tgCurrency :: !EntryCur
|
||||||
, tgTo :: !(TxHalfGetter ToEntryGetter)
|
, tgAcnt :: !EntryAcnt
|
||||||
, tgCurrency :: !EntryCur
|
, tgEntries :: ![EntryGetter]
|
||||||
, tgOtherEntries :: ![TxSubGetter]
|
|
||||||
, tgScale :: !Double
|
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
@ -11,11 +12,11 @@ module Internal.Types.Main
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Decimal
|
|
||||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||||
import Dhall hiding (embed, maybe)
|
import Dhall hiding (embed, maybe)
|
||||||
import Internal.Types.Database
|
import Internal.Types.Database
|
||||||
import Internal.Types.Dhall
|
import Internal.Types.Dhall
|
||||||
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.NonEmpty as NE
|
import qualified RIO.NonEmpty as NE
|
||||||
|
@ -26,166 +27,99 @@ import Text.Regex.TDFA
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- database cache types
|
-- database cache types
|
||||||
|
|
||||||
type MonadFinance = MonadReader TxState
|
data ConfigHashes = ConfigHashes
|
||||||
|
{ chIncome :: ![Int]
|
||||||
data DeleteTxs = DeleteTxs
|
, chExpense :: ![Int]
|
||||||
{ dtCommits :: ![CommitRId]
|
, chManual :: ![Int]
|
||||||
, dtTxs :: ![TransactionRId]
|
, chImport :: ![Int]
|
||||||
, 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
|
|
||||||
}
|
}
|
||||||
|
|
||||||
type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs
|
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||||
|
|
||||||
type PreBudgetCRUD = BudgetCRUDOps Budget
|
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
|
||||||
|
|
||||||
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 TagMap = M.Map TagID TagRId
|
type TagMap = M.Map TagID TagRId
|
||||||
|
|
||||||
data CRUDOps c r u d = CRUDOps
|
data DBState = DBState
|
||||||
{ coCreate :: !c
|
{ kmCurrency :: !CurrencyMap
|
||||||
, coRead :: !r
|
, kmAccount :: !AccountMap
|
||||||
, coUpdate :: !u
|
, kmTag :: !TagMap
|
||||||
, coDelete :: !d
|
, kmBudgetInterval :: !DaySpan
|
||||||
|
, kmStatementInterval :: !DaySpan
|
||||||
|
, kmNewCommits :: ![Int]
|
||||||
}
|
}
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
data CachedEntry
|
data DBUpdates = DBUpdates
|
||||||
= CachedLink EntryIndex LinkScale
|
{ duOldCommits :: ![Int]
|
||||||
| CachedBalance Decimal
|
, duNewTagIds :: ![Entity TagR]
|
||||||
| CachedPercent Double
|
, duNewAcntPaths :: ![AccountPathR]
|
||||||
|
, duNewAcntIds :: ![Entity AccountR]
|
||||||
data TxSortKey = TxSortKey
|
, duNewCurrencyIds :: ![Entity CurrencyR]
|
||||||
{ tskDate :: !Day
|
|
||||||
, tskPriority :: !Int
|
|
||||||
, tskDesc :: !TxDesc
|
|
||||||
}
|
}
|
||||||
deriving (Show, Eq, Ord)
|
|
||||||
|
|
||||||
-- TODO this should actually be a ReadTx since it will be compared with other
|
type CurrencyM = Reader CurrencyMap
|
||||||
-- 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)
|
|
||||||
|
|
||||||
data UpdateEntry i v = UpdateEntry
|
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
|
||||||
{ ueID :: !i
|
|
||||||
, ueAcnt :: !AccountRId
|
|
||||||
, ueValue :: !v
|
|
||||||
, ueIndex :: !EntryIndex
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
deriving instance Functor (UpdateEntry i)
|
type KeyTx = Tx KeyEntry
|
||||||
|
|
||||||
newtype LinkScale = LinkScale {unLinkScale :: Double}
|
type TreeR = Tree ([T.Text], AccountRId)
|
||||||
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
|
|
||||||
|
|
||||||
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
|
type MonadFinance = MonadReader DBState
|
||||||
deriving newtype (Num, Show)
|
|
||||||
|
|
||||||
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
|
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
||||||
|
askDBState = asks
|
||||||
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)
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- misc
|
-- 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
|
data TxRecord = TxRecord
|
||||||
{ trDate :: !Day
|
{ trDate :: !Day
|
||||||
, trAmount :: !Decimal
|
, trAmount :: !Rational
|
||||||
, trDesc :: !TxDesc
|
, trDesc :: !T.Text
|
||||||
, trOther :: !(M.Map T.Text T.Text)
|
, trOther :: !(M.Map T.Text T.Text)
|
||||||
, trFile :: !FilePath
|
, trFile :: !FilePath
|
||||||
}
|
}
|
||||||
deriving (Show, Eq, Ord)
|
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 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 :: AcntType -> AcntSign
|
||||||
accountSign AssetT = Debit
|
accountSign AssetT = Debit
|
||||||
accountSign ExpenseT = Debit
|
accountSign ExpenseT = Debit
|
||||||
|
@ -193,81 +127,21 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = Credit
|
accountSign EquityT = Credit
|
||||||
|
|
||||||
data HalfEntrySet v0 vN = HalfEntrySet
|
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
|
||||||
{ hesPrimary :: !(Entry AcntID v0 TagID)
|
|
||||||
, hesOther :: ![Entry AcntID vN TagID]
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
data EntrySet v0 vp0 vpN vtN = EntrySet
|
type BalEntry = Entry AcntID Rational CurID TagID
|
||||||
{ esTotalValue :: !v0
|
|
||||||
, esCurrency :: !CurrencyRId
|
|
||||||
, esFrom :: !(HalfEntrySet vp0 vpN)
|
|
||||||
, esTo :: !(HalfEntrySet () vtN)
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
|
type RawTx = Tx RawEntry
|
||||||
|
|
||||||
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
|
type BalTx = Tx BalEntry
|
||||||
|
|
||||||
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)
|
|
||||||
|
|
||||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- exception types
|
-- exception types
|
||||||
|
|
||||||
|
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
|
||||||
|
|
||||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||||
|
|
||||||
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
||||||
|
@ -279,53 +153,50 @@ data LookupSuberr
|
||||||
| DBKey !EntryIDType
|
| DBKey !EntryIDType
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
data AllocationSuberr
|
||||||
|
= NoAllocations
|
||||||
|
| ExceededTotal
|
||||||
|
| MissingBlank
|
||||||
|
| TooManyBlanks
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||||
|
|
||||||
data DBLinkSubError
|
data InsertError
|
||||||
= DBLinkNoScale
|
|
||||||
| DBLinkNoValue
|
|
||||||
| DBLinkInvalidValue !Rational !Bool
|
|
||||||
| DBLinkInvalidBalance
|
|
||||||
| DBLinkInvalidPercent
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
data DBSubError
|
|
||||||
= DBShouldBeEmpty
|
|
||||||
| DBMultiScope
|
|
||||||
| DBUpdateUnbalanced
|
|
||||||
| DBLinkError !EntryRId !DBLinkSubError
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
data AppError
|
|
||||||
= RegexError !T.Text
|
= RegexError !T.Text
|
||||||
| MatchValPrecisionError !Natural !Natural
|
| MatchValPrecisionError !Natural !Natural
|
||||||
| AccountTypeError !AcntID !(NE.NonEmpty AcntType)
|
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
||||||
| StatementIOError !T.Text
|
| InsertIOError !T.Text
|
||||||
| ParseError !T.Text
|
| ParseError !T.Text
|
||||||
| ConversionError !T.Text !Bool
|
| ConversionError !T.Text
|
||||||
| LookupError !LookupSuberr !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)
|
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||||
| StatementError ![TxRecord] ![StatementParserRe]
|
| StatementError ![TxRecord] ![MatchRe]
|
||||||
| PeriodError !Day !Day
|
| PeriodError !Day !Day
|
||||||
| LinkError !EntryIndex !EntryIndex
|
|
||||||
| DBError !DBSubError
|
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
newtype AppException = AppException [AppError]
|
newtype InsertException = InsertException [InsertError]
|
||||||
deriving (Show, Semigroup) via [AppError]
|
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)
|
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -87,7 +87,6 @@ dependencies:
|
||||||
- filepath
|
- filepath
|
||||||
- mtl
|
- mtl
|
||||||
- persistent-mtl >= 0.3.0.0
|
- persistent-mtl >= 0.3.0.0
|
||||||
- Decimal >= 0.5.2
|
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: lib/
|
source-dirs: lib/
|
||||||
|
|
Loading…
Reference in New Issue