Compare commits
No commits in common. "master" and "fix_cache" have entirely different histories.
|
|
@ -204,12 +204,15 @@ runDumpAccountKeys c = do
|
|||
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
||||
runSync threads c bs hs = do
|
||||
setNumCapabilities threads
|
||||
-- putStrLn "reading config"
|
||||
config <- readConfig c
|
||||
-- putStrLn "reading statements"
|
||||
(bs', hs') <-
|
||||
fmap (bimap concat concat . partitionEithers) $
|
||||
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
|
||||
(Left <$> bs) ++ (Right <$> hs)
|
||||
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
||||
putStrLn "doing other stuff"
|
||||
setNumCapabilities 1
|
||||
handle err $ sync pool root config bs' hs'
|
||||
where
|
||||
|
|
|
|||
|
|
@ -278,126 +278,54 @@ let DatePat =
|
|||
-}
|
||||
< Cron : CronPat.Type | Mod : ModPat.Type >
|
||||
|
||||
let TxAmount1_ =
|
||||
\(re : Type) ->
|
||||
{ a1Column : Text
|
||||
, a1Fmt :
|
||||
{-
|
||||
Format of the amount field. Must include three fields for the
|
||||
sign, numerator, and denominator of the amount.
|
||||
-}
|
||||
re
|
||||
}
|
||||
|
||||
let TxAmount1 =
|
||||
{ Type = TxAmount1_ Text
|
||||
, default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
|
||||
}
|
||||
|
||||
let TxAmount2_ =
|
||||
\(re : Type) ->
|
||||
{ a2Positive : Text
|
||||
, a2Negative : Text
|
||||
, a2Fmt :
|
||||
{-
|
||||
Format of the amount field. Must include two fields for the
|
||||
numerator and denominator of the amount.
|
||||
-}
|
||||
re
|
||||
}
|
||||
|
||||
let TxAmount2 =
|
||||
{ Type = TxAmount2_ Text
|
||||
, default =
|
||||
{ a2Positive = "Deposit"
|
||||
, a2Negative = "Withdraw"
|
||||
, a2Fmt = "([0-9\\.]+)"
|
||||
}
|
||||
}
|
||||
|
||||
let TxAmountSpec_ =
|
||||
\(re : Type) ->
|
||||
< AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
|
||||
|
||||
let TxOpts_ =
|
||||
{-
|
||||
Additional metadata to use when parsing a statement
|
||||
-}
|
||||
{- 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
|
||||
{ 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.
|
||||
-}
|
||||
re
|
||||
}
|
||||
, default =
|
||||
{ toDate = "Date"
|
||||
, toAmount = "Amount"
|
||||
, toDesc = "Description"
|
||||
, toOther = [] : List Text
|
||||
, toDateFmt = "%0m/%0d/%Y"
|
||||
, toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
|
||||
}
|
||||
}
|
||||
|
||||
let TxAmountSpec = TxAmountSpec_ Text
|
||||
|
||||
let TxOpts =
|
||||
{ Type = TxOpts_ Text
|
||||
, default =
|
||||
{ toDate = "Date"
|
||||
, toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
|
||||
, toDesc = "Description"
|
||||
, toOther = [] : List Text
|
||||
, toDateFmt = "%0m/%0d/%Y"
|
||||
, toSkipBlankDate = False
|
||||
, toSkipBlankAmount = False
|
||||
, toSkipBlankDescription = False
|
||||
, toSkipBlankOther = [] : List Text
|
||||
, toSkipMissingFields = False
|
||||
}
|
||||
}
|
||||
let TxOpts = TxOpts_ Text
|
||||
|
||||
let Field =
|
||||
{-
|
||||
|
|
@ -1056,40 +984,54 @@ let Income =
|
|||
}
|
||||
}
|
||||
|
||||
let AcntMatcher_ =
|
||||
let AcntSet =
|
||||
{-
|
||||
Regex pattern by which matching account ids will be identified
|
||||
A list of account IDs represented as a set.
|
||||
-}
|
||||
\(re : Type) ->
|
||||
{ Type = { amPat : re, amInvert : Bool }, default.amInvert = False }
|
||||
{ Type =
|
||||
{ asList : List AcntID
|
||||
, asInclude :
|
||||
{-
|
||||
If true, tests for account membership in this set will return
|
||||
true if the account is in the set. Invert this behavior otherwise.
|
||||
-}
|
||||
Bool
|
||||
}
|
||||
, default = { asList = [] : List AcntID, asInclude = False }
|
||||
}
|
||||
|
||||
let AcntMatcher = AcntMatcher_ Text
|
||||
|
||||
let TransferMatcher_ =
|
||||
let TransferMatcher =
|
||||
{-
|
||||
Means to match a transfer (which will be used to "clone" it in some
|
||||
fashion)
|
||||
-}
|
||||
\(re : Type) ->
|
||||
{ tmFrom : Optional (AcntMatcher_ re).Type
|
||||
, tmTo : Optional (AcntMatcher_ re).Type
|
||||
, tmDate :
|
||||
{-
|
||||
If given, means to match the date of a transfer.
|
||||
-}
|
||||
Optional DateMatcher
|
||||
, tmVal :
|
||||
{-
|
||||
If given, means to match the value of a transfer.
|
||||
-}
|
||||
ValMatcher.Type
|
||||
}
|
||||
|
||||
let TransferMatcher =
|
||||
{ Type = TransferMatcher_ Text
|
||||
{ Type =
|
||||
{ tmFrom :
|
||||
{-
|
||||
List of accounts (which may be empty) to match with the
|
||||
starting account in a transfer.
|
||||
-}
|
||||
AcntSet.Type
|
||||
, tmTo :
|
||||
{-
|
||||
List of accounts (which may be empty) to match with the
|
||||
ending account in a transfer.
|
||||
-}
|
||||
AcntSet.Type
|
||||
, tmDate :
|
||||
{-
|
||||
If given, means to match the date of a transfer.
|
||||
-}
|
||||
Optional DateMatcher
|
||||
, tmVal :
|
||||
{-
|
||||
If given, means to match the value of a transfer.
|
||||
-}
|
||||
ValMatcher.Type
|
||||
}
|
||||
, default =
|
||||
{ tmFrom = None AcntMatcher.Type
|
||||
, tmTo = None AcntMatcher.Type
|
||||
{ tmFrom = AcntSet.default
|
||||
, tmTo = AcntSet.default
|
||||
, tmDate = None DateMatcher
|
||||
, tmVal = ValMatcher.default
|
||||
}
|
||||
|
|
@ -1206,9 +1148,9 @@ in { CurID
|
|||
, Budget
|
||||
, Allocation
|
||||
, Amount
|
||||
, TransferMatcher_
|
||||
, TransferMatcher
|
||||
, ShadowTransfer
|
||||
, AcntSet
|
||||
, TaggedAcnt
|
||||
, AccountTree
|
||||
, Account
|
||||
|
|
@ -1235,13 +1177,4 @@ in { CurID
|
|||
, TransferAmount
|
||||
, MultiAlloAmount
|
||||
, SingleAlloAmount
|
||||
, AcntMatcher_
|
||||
, AcntMatcher
|
||||
, TxAmountSpec
|
||||
, TxAmountSpec_
|
||||
, TxAmount1_
|
||||
, TxAmount2_
|
||||
, TxAmount1
|
||||
, TxAmount2
|
||||
, BudgetTransfer
|
||||
}
|
||||
|
|
|
|||
|
|
@ -38,8 +38,9 @@ readBudget
|
|||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers c budgetSpan bgtTransfers
|
||||
combineErrorM (concat <$> res1) res2 $ \is ts ->
|
||||
addShadowTransfers bgtShadowTransfers (is ++ ts)
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
return $ txs ++ shadow
|
||||
where
|
||||
c = CommitR (CommitHash $ hash b) CTBudget
|
||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||
|
|
@ -145,7 +146,7 @@ readIncome
|
|||
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
||||
let primary =
|
||||
EntrySet
|
||||
{ esTotalValue = -gross
|
||||
{ esTotalValue = gross
|
||||
, esCurrency = cpID cp
|
||||
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
|
||||
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
|
||||
|
|
@ -345,31 +346,26 @@ fromShadow
|
|||
-> ShadowTransfer
|
||||
-> m (Maybe ShadowEntrySet)
|
||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
|
||||
combineErrorM curRes mRes $ \cur compiled -> do
|
||||
res <- liftExcept $ shadowMatches compiled tx
|
||||
combineErrorM curRes shaRes $ \cur sha -> do
|
||||
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
||||
return $ if not res then Nothing else Just es
|
||||
return $ if not sha then Nothing else Just es
|
||||
where
|
||||
curRes = lookupCurrencyKey stCurrency
|
||||
mRes = liftExcept $ compileMatch stMatch
|
||||
curRes = lookupCurrencyKey (CurID stCurrency)
|
||||
shaRes = liftExcept $ shadowMatches stMatch tx
|
||||
|
||||
shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
|
||||
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
|
||||
shadowMatches
|
||||
TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
|
||||
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
|
||||
memberMaybe fa tmFrom
|
||||
&& memberMaybe ta tmTo
|
||||
&& maybe True (`dateMatches` txmDate) tmDate
|
||||
&& valRes
|
||||
where
|
||||
|
|
@ -378,22 +374,8 @@ shadowMatches
|
|||
getAcntFrom = getAcnt esFrom
|
||||
getAcntTo = getAcnt esTo
|
||||
getAcnt f = eAcnt . hesPrimary . f
|
||||
acntMatches (AcntID a) = maybe (return True) (match' a)
|
||||
match' a AcntMatcher_ {amPat, amInvert} =
|
||||
(if amInvert then not else id) <$> matchMaybe a amPat
|
||||
|
||||
compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
|
||||
compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
|
||||
combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
|
||||
where
|
||||
go a@AcntMatcher_ {amPat} = do
|
||||
(_, p) <- compileRegex False amPat
|
||||
return $ a {amPat = p}
|
||||
tres = mapM go tmTo
|
||||
fres = mapM go tmFrom
|
||||
|
||||
-- memberMaybe x AcntSet {asList, asInclude} =
|
||||
-- (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- random
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE ImplicitPrelude #-}
|
||||
|
||||
module Internal.Database
|
||||
( runDB
|
||||
, readDB
|
||||
|
|
@ -22,7 +24,6 @@ import Control.Monad.IO.Rerunnable
|
|||
import Control.Monad.Logger
|
||||
import Data.Decimal
|
||||
import Data.Hashable
|
||||
import qualified Data.Text.IO as TI
|
||||
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
|
|
@ -39,11 +40,12 @@ import Database.Persist.Sqlite hiding
|
|||
, (==.)
|
||||
, (||.)
|
||||
)
|
||||
-- import GHC.Err
|
||||
import Internal.Budget
|
||||
import Internal.History
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, logDebug, on, (^.))
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
|
|
@ -73,7 +75,15 @@ sync pool root c bs hs = do
|
|||
b <- liftIOExceptT $ readBudgetCRUD budgets
|
||||
h <- readHistoryCRUD root history
|
||||
return (b, h)
|
||||
liftIO $ TI.putStr $ formatBuildPlan history budgets
|
||||
-- liftIO $ print $ length $ coCreate budgets
|
||||
liftIO $ print $ length $ fst $ coCreate history
|
||||
liftIO $ print $ bimap length length $ coCreate history
|
||||
liftIO $ print $ length $ coRead history
|
||||
liftIO $ print $ length $ coUpdate history
|
||||
liftIO $ print $ (\(DeleteTxs e a b c' d) -> (length e, length a, length b, length c', length d)) $ coDelete history
|
||||
-- liftIO $ print $ length $ M.elems $ tsAccountMap txState
|
||||
-- liftIO $ print $ length $ M.elems $ tsCurrencyMap txState
|
||||
-- liftIO $ print $ length $ M.elems $ tsTagMap txState
|
||||
|
||||
-- Update the DB.
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
|
||||
|
|
@ -88,35 +98,6 @@ sync pool root c bs hs = do
|
|||
-- thrown error should be caught despite possibly needing to be rerun
|
||||
rerunnableIO $ fromEither res
|
||||
|
||||
formatBuildPlan :: PreHistoryCRUD -> PreBudgetCRUD -> T.Text
|
||||
formatBuildPlan
|
||||
CRUDOps {coCreate = hc, coRead = hr, coUpdate = hu, coDelete = hd}
|
||||
CRUDOps {coCreate = bc, coDelete = bd} =
|
||||
T.unlines $ "Build plan:" : (T.append " " <$> ht ++ [""] ++ bt)
|
||||
where
|
||||
ht =
|
||||
[ T.append "History transfers to create: " $ tshow hCt
|
||||
, T.append "History statements to create: " $ tshow hCs
|
||||
, T.append "History entries to read: " $ tshow $ length hr
|
||||
, T.append "History entry sets to update: " $ tshow $ length hu
|
||||
]
|
||||
++ formatDel "History" hd
|
||||
bt =
|
||||
T.append "Budgets to create: " (tshow $ bgtLabel <$> bc)
|
||||
: formatDel "Budget" bd
|
||||
toDel what thing n = T.unwords [what, thing, "to delete:", tshow n]
|
||||
formatDel what (DeleteTxs e a b c' d) =
|
||||
[ f "commits" e
|
||||
, f "transactions" a
|
||||
, f "entry sets" b
|
||||
, f "entries" c'
|
||||
, f "tag relations" d
|
||||
]
|
||||
where
|
||||
f :: T.Text -> [a] -> T.Text
|
||||
f thing = toDel what thing . length
|
||||
(hCt, hCs) = bimap length length hc
|
||||
|
||||
runDB
|
||||
:: MonadUnliftIO m
|
||||
=> SqlConfig
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ import qualified RIO.Text as T
|
|||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
import Text.Regex.TDFA hiding (matchAll)
|
||||
import Text.Regex.TDFA.Text
|
||||
|
||||
readHistoryCRUD
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
|
|
@ -32,7 +33,7 @@ readHistoryCRUD
|
|||
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
|
||||
-- TODO multithread this for some extra fun :)
|
||||
|
||||
ss' <- mapErrorsIO (readHistStmt root) ss
|
||||
ss' <- mapM (readHistStmt root) ss
|
||||
fromEitherM $ runExceptT $ do
|
||||
let sRes = mapErrors (ExceptT . return) ss'
|
||||
let tRes = mapErrors readHistTransfer ts
|
||||
|
|
@ -112,93 +113,39 @@ readImport_ n delim tns p = do
|
|||
-- TODO handle this better, this maybe thing is a hack to skip lines with
|
||||
-- blank dates but will likely want to make this more flexible
|
||||
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
||||
parseTxRecord
|
||||
p
|
||||
TxOpts
|
||||
{ toDate
|
||||
, toDesc
|
||||
, toAmount
|
||||
, toOther
|
||||
, toDateFmt
|
||||
, toSkipBlankDate
|
||||
, toSkipBlankAmount
|
||||
, toSkipBlankDescription
|
||||
, toSkipBlankOther
|
||||
, toSkipMissingFields
|
||||
}
|
||||
r =
|
||||
do
|
||||
-- TODO this is confusing as hell
|
||||
--
|
||||
-- try and parse all fields; if a parse fails, either trip an error
|
||||
-- or return a Nothing if we want to deliberately skip missing fields
|
||||
d <- getField toDate
|
||||
e <- getField toDesc
|
||||
os <-
|
||||
fmap M.fromList . sequence
|
||||
<$> mapM (\n -> fmap (n,) <$> getField n) toOther
|
||||
(af, ax) <- case toAmount of
|
||||
-- the amount column is extra confusing because it can either be one
|
||||
-- or two columns, so keep track of this with a maybe
|
||||
AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
|
||||
f <- getField a1Column
|
||||
return (a1Fmt, Right <$> f)
|
||||
AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
|
||||
f1 <- getField a2Positive
|
||||
f2 <- getField a2Negative
|
||||
return $ (a2Fmt,) $ case (f1, f2) of
|
||||
(Just a, Just b) -> Just $ Left (a, b)
|
||||
_ -> Nothing
|
||||
case (d, e, os, ax) of
|
||||
-- If all lookups were successful, check that none of the fields are
|
||||
-- blank, and if they are return nothing to skip this line
|
||||
(Just d', Just e', Just os', Just ax') ->
|
||||
if (toSkipBlankDate && d' == "")
|
||||
|| (toSkipBlankDescription && e' == "")
|
||||
|| (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
|
||||
|| elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
|
||||
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
|
||||
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
|
||||
d <- r .: T.encodeUtf8 toDate
|
||||
if d == ""
|
||||
then return Nothing
|
||||
else do
|
||||
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||
e <- r .: T.encodeUtf8 toDesc
|
||||
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os p
|
||||
|
||||
matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
|
||||
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
(ms_, [], []) -> return ms_
|
||||
(_, us, ns) -> throwError $ AppException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [StatementParserRe] -> [MatchGroup]
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
fmap matchToGroup
|
||||
. L.groupBy (\a b -> spPriority a == spPriority b)
|
||||
. L.sortOn (Down . spPriority)
|
||||
|
||||
matchToGroup :: [StatementParserRe] -> MatchGroup
|
||||
matchToGroup :: [MatchRe] -> MatchGroup
|
||||
matchToGroup ms =
|
||||
uncurry MatchGroup $
|
||||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) ms
|
||||
|
||||
data MatchGroup = MatchGroup
|
||||
{ mgDate :: ![StatementParserRe]
|
||||
, mgNoDate :: ![StatementParserRe]
|
||||
{ mgDate :: ![MatchRe]
|
||||
, mgNoDate :: ![MatchRe]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -237,9 +184,9 @@ zipperSlice f x = go
|
|||
|
||||
zipperMatch
|
||||
:: MonadFinance m
|
||||
=> Unzipped StatementParserRe
|
||||
=> Unzipped MatchRe
|
||||
-> TxRecord
|
||||
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
|
||||
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||
|
|
@ -254,9 +201,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
|||
|
||||
zipperMatch'
|
||||
:: MonadFinance m
|
||||
=> Zipped StatementParserRe
|
||||
=> Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
|
||||
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||
zipperMatch' z x = go z
|
||||
where
|
||||
go (Zipped bs (a : as)) = do
|
||||
|
|
@ -267,7 +214,7 @@ zipperMatch' z x = go z
|
|||
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
go z' = return (z', MatchFail)
|
||||
|
||||
matchDec :: StatementParserRe -> Maybe StatementParserRe
|
||||
matchDec :: MatchRe -> Maybe MatchRe
|
||||
matchDec m = case spTimes m of
|
||||
Just 1 -> Nothing
|
||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
|
|
@ -277,7 +224,7 @@ matchAll
|
|||
:: MonadFinance m
|
||||
=> [MatchGroup]
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
|
|
@ -291,7 +238,7 @@ matchGroup
|
|||
:: MonadFinance m
|
||||
=> MatchGroup
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||
(md, rest, ud) <- matchDates ds rs
|
||||
(mn, unmatched, un) <- matchNonDates ns rest
|
||||
|
|
@ -299,9 +246,9 @@ matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
|||
|
||||
matchDates
|
||||
:: MonadFinance m
|
||||
=> [StatementParserRe]
|
||||
=> [MatchRe]
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
|
|
@ -324,9 +271,9 @@ matchDates ms = go ([], [], initZipper ms)
|
|||
|
||||
matchNonDates
|
||||
:: MonadFinance m
|
||||
=> [StatementParserRe]
|
||||
=> [MatchRe]
|
||||
-> [TxRecord]
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
|
|
@ -343,11 +290,7 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
matches
|
||||
:: MonadFinance m
|
||||
=> StatementParserRe
|
||||
-> TxRecord
|
||||
-> AppExceptT m (MatchRes (Tx ()))
|
||||
matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
|
||||
matches
|
||||
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
|
|
@ -522,17 +465,11 @@ readRational s = case T.split (== '.') s of
|
|||
err = throwError $ AppException [ConversionError s False]
|
||||
|
||||
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
|
||||
compileOptions = mapM (compileRegex True)
|
||||
compileOptions o@TxOpts {toAmountFmt = pat} = do
|
||||
re <- compileRegex True pat
|
||||
return $ o {toAmountFmt = re}
|
||||
|
||||
-- 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 :: StatementParser T.Text -> AppExcept MatchRe
|
||||
compileMatch m@StatementParser {spDesc, spOther} = do
|
||||
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
|
||||
where
|
||||
|
|
@ -540,15 +477,42 @@ compileMatch m@StatementParser {spDesc, spOther} = do
|
|||
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
|
||||
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
|
||||
compileRegex groups pat = case res of
|
||||
Right re -> return (pat, re)
|
||||
Left _ -> throwError $ AppException [RegexError pat]
|
||||
where
|
||||
res =
|
||||
compile
|
||||
(blankCompOpt {newSyntax = True})
|
||||
(blankExecOpt {captureGroups = groups})
|
||||
pat
|
||||
|
||||
matchMaybe :: T.Text -> Regex -> AppExcept Bool
|
||||
matchMaybe q re = case execute re q of
|
||||
Right res -> return $ isJust res
|
||||
Left _ -> throwError $ AppException [RegexError "this should not happen"]
|
||||
|
||||
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
|
||||
matchGroupsMaybe q re = case regexec re q of
|
||||
Right Nothing -> []
|
||||
Right (Just (_, _, _, xs)) -> xs
|
||||
-- this should never fail as regexec always returns Right
|
||||
Left _ -> []
|
||||
|
||||
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
|
||||
parseDecimal (pat, re) s = case matchGroupsMaybe s re of
|
||||
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
|
||||
[sign, x, y] -> do
|
||||
d <- readT "decimal" y
|
||||
let p = T.length y
|
||||
(k, w) <- readWhole sign x
|
||||
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
|
||||
_ -> msg "malformed decimal"
|
||||
where
|
||||
readT what t = case readMaybe $ T.unpack t of
|
||||
Just d -> return $ fromInteger d
|
||||
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
|
||||
msg :: MonadFail m => T.Text -> m a
|
||||
msg m =
|
||||
fail $
|
||||
|
|
@ -558,10 +522,7 @@ parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
|
|||
| 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
|
||||
readWhole sign x = do
|
||||
w <- readT "whole number" x
|
||||
k <- readSign sign
|
||||
return (k, w)
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ 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)
|
||||
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
|
||||
|
||||
newtype Precision = Precision {unPrecision :: Word8}
|
||||
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
|
||||
|
|
|
|||
|
|
@ -49,16 +49,17 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
||||
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
|
||||
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
|
||||
, SingleConstructor
|
||||
"Amount"
|
||||
"Amount"
|
||||
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
|
||||
, SingleConstructor
|
||||
"AcntMatcher_"
|
||||
"AcntMatcher_"
|
||||
"\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
|
||||
"TxOpts"
|
||||
"TxOpts"
|
||||
"\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
|
||||
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
|
||||
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
||||
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
||||
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
||||
|
|
@ -87,7 +88,11 @@ deriveProduct
|
|||
, "CronPat"
|
||||
, "DatePat"
|
||||
, "TaggedAcnt"
|
||||
, "Budget"
|
||||
, "Income"
|
||||
, "ShadowTransfer"
|
||||
, "TransferMatcher"
|
||||
, "AcntSet"
|
||||
, "DateMatcher"
|
||||
, "ValMatcher"
|
||||
, "YMDMatcher"
|
||||
|
|
@ -186,33 +191,15 @@ newtype BudgetName = BudgetName {unBudgetName :: T.Text}
|
|||
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
|
||||
data Budget = Budget
|
||||
{ bgtLabel :: !BudgetName
|
||||
, bgtIncomes :: ![Income]
|
||||
, bgtPretax :: ![MultiAllocation PretaxValue]
|
||||
, bgtTax :: ![MultiAllocation TaxValue]
|
||||
, bgtPosttax :: ![MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: ![PairedTransfer]
|
||||
, bgtShadowTransfers :: ![ShadowTransfer]
|
||||
{ bgtLabel :: BudgetName
|
||||
, bgtIncomes :: [Income]
|
||||
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||
, bgtTax :: [MultiAllocation TaxValue]
|
||||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: [PairedTransfer]
|
||||
, bgtShadowTransfers :: [ShadowTransfer]
|
||||
, bgtInterval :: !(Maybe Interval)
|
||||
}
|
||||
deriving (Generic, Hashable, FromDhall)
|
||||
|
||||
data ShadowTransfer = ShadowTransfer
|
||||
{ stFrom :: !TaggedAcnt
|
||||
, stTo :: !TaggedAcnt
|
||||
, stCurrency :: !CurID
|
||||
, stDesc :: !Text
|
||||
, stMatch :: !(TransferMatcher_ Text)
|
||||
, stRatio :: !Double
|
||||
}
|
||||
deriving (Generic, Hashable, FromDhall)
|
||||
|
||||
data TransferMatcher_ re = TransferMatcher_
|
||||
{ tmFrom :: !(Maybe (AcntMatcher_ re))
|
||||
, tmTo :: !(Maybe (AcntMatcher_ re))
|
||||
, tmDate :: !(Maybe DateMatcher)
|
||||
, tmVal :: !ValMatcher
|
||||
}
|
||||
|
||||
deriving instance Hashable PretaxValue
|
||||
|
||||
|
|
@ -226,6 +213,8 @@ deriving instance Hashable TaxValue
|
|||
|
||||
deriving instance Hashable PosttaxValue
|
||||
|
||||
deriving instance Hashable Budget
|
||||
|
||||
deriving instance Hashable TransferValue
|
||||
|
||||
deriving instance Hashable TransferType
|
||||
|
|
@ -325,17 +314,11 @@ data Transfer a c w v = Transfer
|
|||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
deriving instance Generic (TransferMatcher_ Text)
|
||||
deriving instance Hashable ShadowTransfer
|
||||
|
||||
deriving instance Hashable (TransferMatcher_ Text)
|
||||
deriving instance Hashable AcntSet
|
||||
|
||||
deriving instance FromDhall (TransferMatcher_ Text)
|
||||
|
||||
deriving instance Generic (AcntMatcher_ Text)
|
||||
|
||||
deriving instance Hashable (AcntMatcher_ Text)
|
||||
|
||||
deriving instance FromDhall (AcntMatcher_ Text)
|
||||
deriving instance Hashable TransferMatcher
|
||||
|
||||
deriving instance Hashable ValMatcher
|
||||
|
||||
|
|
@ -466,44 +449,12 @@ deriving instance Eq a => Eq (TxOpts a)
|
|||
|
||||
deriving instance Generic (TxOpts a)
|
||||
|
||||
deriving instance Hashable (TxOpts T.Text)
|
||||
deriving instance Hashable a => Hashable (TxOpts a)
|
||||
|
||||
deriving instance FromDhall (TxOpts T.Text)
|
||||
deriving instance FromDhall a => FromDhall (TxOpts a)
|
||||
|
||||
deriving instance Show a => Show (TxOpts a)
|
||||
|
||||
deriving instance Eq re => Eq (TxAmount1 re)
|
||||
|
||||
deriving instance Eq re => Eq (TxAmount2 re)
|
||||
|
||||
deriving instance Show re => Show (TxAmount1 re)
|
||||
|
||||
deriving instance Show re => Show (TxAmount2 re)
|
||||
|
||||
deriving instance Generic (TxAmount1 T.Text)
|
||||
|
||||
deriving instance Generic (TxAmount2 T.Text)
|
||||
|
||||
deriving instance Hashable (TxAmount1 T.Text)
|
||||
|
||||
deriving instance Hashable (TxAmount2 T.Text)
|
||||
|
||||
deriving instance FromDhall (TxAmount1 T.Text)
|
||||
|
||||
deriving instance FromDhall (TxAmount2 T.Text)
|
||||
|
||||
deriving instance Functor TxAmount1
|
||||
|
||||
deriving instance Functor TxAmount2
|
||||
|
||||
deriving instance Foldable TxAmount1
|
||||
|
||||
deriving instance Foldable TxAmount2
|
||||
|
||||
deriving instance Traversable TxAmount1
|
||||
|
||||
deriving instance Traversable TxAmount2
|
||||
|
||||
data Statement = Statement
|
||||
{ stmtPaths :: ![FilePath]
|
||||
, stmtParsers :: ![StatementParser T.Text]
|
||||
|
|
@ -513,29 +464,6 @@ data Statement = Statement
|
|||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall, Show)
|
||||
|
||||
data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
|
||||
deriving (Eq, Show, Functor, Foldable, Traversable)
|
||||
|
||||
deriving instance Generic (TxAmountSpec T.Text)
|
||||
|
||||
deriving instance FromDhall (TxAmountSpec T.Text)
|
||||
|
||||
deriving instance Hashable (TxAmountSpec T.Text)
|
||||
|
||||
data TxOpts re = TxOpts
|
||||
{ toDate :: !T.Text
|
||||
, toAmount :: !(TxAmountSpec re)
|
||||
, toDesc :: !T.Text
|
||||
, toOther :: ![T.Text]
|
||||
, toDateFmt :: !T.Text
|
||||
, toSkipBlankDate :: !Bool
|
||||
, toSkipBlankAmount :: !Bool
|
||||
, toSkipBlankDescription :: !Bool
|
||||
, toSkipBlankOther :: ![Text]
|
||||
, toSkipMissingFields :: !Bool
|
||||
}
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
|
||||
-- | the value of a field in entry (text version)
|
||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||
-- between the lookup and some other value
|
||||
|
|
|
|||
|
|
@ -306,7 +306,7 @@ data AppError
|
|||
| LookupError !LookupSuberr !T.Text
|
||||
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![StatementParserRe]
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
| PeriodError !Day !Day
|
||||
| LinkError !EntryIndex !EntryIndex
|
||||
| DBError !DBSubError
|
||||
|
|
@ -323,9 +323,7 @@ type AppExceptT = ExceptT AppException
|
|||
|
||||
type AppExcept = AppExceptT Identity
|
||||
|
||||
type StatementParserRe = StatementParser (T.Text, Regex)
|
||||
|
||||
type TransferMatcherRe = TransferMatcher_ Regex
|
||||
type MatchRe = StatementParser (T.Text, Regex)
|
||||
|
||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||
|
||||
|
|
|
|||
|
|
@ -51,9 +51,6 @@ module Internal.Utils
|
|||
, keyVals
|
||||
, realFracToDecimalP
|
||||
, roundToP
|
||||
, compileRegex
|
||||
, matchMaybe
|
||||
, matchGroupsMaybe
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -72,8 +69,6 @@ import RIO.State
|
|||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
import Text.Regex.TDFA hiding (matchAll)
|
||||
import Text.Regex.TDFA.Text
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- intervals
|
||||
|
|
@ -130,7 +125,7 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
|||
|
||||
expandMDYPat :: Natural -> Natural -> MDYPat -> AppExcept [Natural]
|
||||
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
|
||||
expandMDYPat lower upper (Multi xs) = return $ dropWhile (< lower) $ takeWhile (<= upper) xs
|
||||
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
|
||||
expandMDYPat lower upper (After x) = return [max lower x .. upper]
|
||||
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
|
||||
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
|
||||
|
|
@ -499,7 +494,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
|
|||
, ("description", doubleQuote $ unTxDesc e)
|
||||
]
|
||||
|
||||
showMatch :: StatementParserRe -> T.Text
|
||||
showMatch :: MatchRe -> T.Text
|
||||
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
|
||||
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
|
||||
where
|
||||
|
|
@ -698,12 +693,14 @@ rebalanceTotalEntrySet
|
|||
, utTotalValue
|
||||
} =
|
||||
do
|
||||
(fval, fs, tpairs) <- rebalanceDebit utCurrency utFromRO utFromUnk
|
||||
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
|
||||
let f0val = utTotalValue - fval
|
||||
modify $ mapAdd_ (f0Acnt, utCurrency) f0val
|
||||
modify $ mapAdd_ (f0Acnt, bc) f0val
|
||||
let tsLinked = tpairs ++ (unlink f0val <$> f0links)
|
||||
ts <- rebalanceCredit utCurrency utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
|
||||
where
|
||||
bc = utCurrency
|
||||
|
||||
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceFullEntrySet
|
||||
|
|
@ -717,13 +714,14 @@ rebalanceFullEntrySet
|
|||
, utCurrency
|
||||
} =
|
||||
do
|
||||
(ftot, fs, tpairs) <- rebalanceDebit utCurrency rs ls
|
||||
ts <- rebalanceCredit utCurrency ftot utTo0 utToUnk utToRO tpairs
|
||||
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
|
||||
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
|
||||
return (fs ++ ts)
|
||||
where
|
||||
(rs, ls) = case utFrom0 of
|
||||
Left x -> (x : utFromRO, utFromUnk)
|
||||
Right x -> (utFromRO, x : utFromUnk)
|
||||
bc = utCurrency
|
||||
|
||||
rebalanceDebit
|
||||
:: BCKey
|
||||
|
|
@ -757,7 +755,7 @@ rebalanceCredit
|
|||
-> [UE_RO]
|
||||
-> [UEBalanced]
|
||||
-> State EntryBals [UEBalanced]
|
||||
rebalanceCredit k tot t0@UpdateEntry {ueAcnt = t0Acnt} us rs bs = do
|
||||
rebalanceCredit k tot t0 us rs bs = do
|
||||
(tval, ts) <-
|
||||
fmap (second catMaybes) $
|
||||
sumM goTo $
|
||||
|
|
@ -765,9 +763,7 @@ rebalanceCredit k tot t0@UpdateEntry {ueAcnt = t0Acnt} us rs bs = do
|
|||
(UETLinked <$> bs)
|
||||
++ (UETUnk <$> us)
|
||||
++ (UETReadOnly <$> rs)
|
||||
let t0val = -(tot + tval)
|
||||
modify $ mapAdd_ (t0Acnt, k) t0val
|
||||
return (t0 {ueValue = StaticValue t0val} : ts)
|
||||
return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
|
||||
where
|
||||
idx = projectUET ueIndex ueIndex ueIndex
|
||||
goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
|
||||
|
|
@ -1041,26 +1037,3 @@ realFracToDecimalP p = realFracToDecimal (unPrecision p)
|
|||
|
||||
roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
|
||||
roundToP p = roundTo (unPrecision p)
|
||||
|
||||
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
|
||||
compileRegex groups pat = case res of
|
||||
Right re -> return (pat, re)
|
||||
Left _ -> throwError $ AppException [RegexError pat]
|
||||
where
|
||||
res =
|
||||
compile
|
||||
(blankCompOpt {newSyntax = True})
|
||||
(blankExecOpt {captureGroups = groups})
|
||||
pat
|
||||
|
||||
matchMaybe :: T.Text -> Regex -> AppExcept Bool
|
||||
matchMaybe q re = case execute re q of
|
||||
Right res -> return $ isJust res
|
||||
Left _ -> throwError $ AppException [RegexError "this should not happen"]
|
||||
|
||||
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
|
||||
matchGroupsMaybe q re = case regexec re q of
|
||||
Right Nothing -> []
|
||||
Right (Just (_, _, _, xs)) -> xs
|
||||
-- this should never fail as regexec always returns Right
|
||||
Left _ -> []
|
||||
|
|
|
|||
Loading…
Reference in New Issue