From 38710b1f568fce2d96cacc7e7d1d2e4fc2bb1536 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 4 May 2023 21:48:21 -0400 Subject: [PATCH] WIP use doubles in config --- dhall/Types.dhall | 31 +++--- dhall/common.dhall | 19 +--- lib/Internal/Database/Ops.hs | 13 ++- lib/Internal/Insert.hs | 179 ++++++++++++++++++++--------------- lib/Internal/Statement.hs | 132 ++++++++++++++++---------- lib/Internal/Types.hs | 46 +++++---- lib/Internal/Utils.hs | 112 ++++++++++++++-------- 7 files changed, 310 insertions(+), 222 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index a4e8704..dbbde81 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -106,6 +106,11 @@ let Currency = The full description of this currency (eg "Yugoslavian Twitcoin") -} Text + , curPrecision : + {- + The number of decimal places for this currency + -} + Natural } let TagID = @@ -273,9 +278,6 @@ let DatePat = -} < Cron : CronPat.Type | Mod : ModPat.Type > -let Decimal = - { whole : Natural, decimal : Natural, precision : Natural, sign : Bool } - let TxOpts = {- Additional metadata to use when parsing a statement -} { Type = @@ -402,7 +404,7 @@ let EntryNumGetter = ConstN: a constant value AmountN: the value of the 'Amount' column -} - < LookupN : Text | ConstN : Decimal | AmountN > + < LookupN : Text | ConstN : Double | AmountN > let EntryTextGetter = {- @@ -595,7 +597,7 @@ let HistTransfer = {- A manually specified historical transfer -} - Transfer AcntID CurID DatePat Decimal + Transfer AcntID CurID DatePat Double let Statement = {- @@ -655,7 +657,7 @@ let Exchange = {- The exchange rate between the currencies. -} - Decimal + Double } let BudgetCurrency = @@ -692,7 +694,7 @@ let PretaxValue = {- The value to be deducted from gross income -} - Decimal + Double , prePercent : {- If true, value is interpreted as a percent of gross income instead of @@ -713,7 +715,7 @@ let TaxBracket = A single tax bracket. Read as "every unit above limit is taxed at this percentage". -} - { tbLowerLimit : Decimal, tbPercent : Decimal } + { tbLowerLimit : Double, tbPercent : Double } let TaxProgression = {- @@ -724,7 +726,7 @@ let TaxProgression = {- Initial amount to subtract from after-pretax-deductions -} - Decimal + Double , tpBrackets : {- Tax brackets to apply after deductions (order does not matter, each @@ -737,7 +739,7 @@ let TaxMethod = {- How to implement a given tax (either a progressive tax or a fixed percent) -} - < TMBracket : TaxProgression | TMPercent : Decimal > + < TMBracket : TaxProgression | TMPercent : Double > let TaxValue = {- @@ -761,7 +763,7 @@ let PosttaxValue = {- The value to be deducted from income remaining after taxes. -} - Decimal + Double , postPercent : {- If true, subtract a percentage from the after-tax remainder instead @@ -794,7 +796,7 @@ let Income = {- The value of the income stream. -} - Decimal + Double , incCurrency : {- The currency in which the income stream is denominated. @@ -931,14 +933,14 @@ let ShadowTransfer = {- Fixed multipler to translate value of matched transfer to this one. -} - Decimal + Double } let BudgetTransferValue = {- Means to determine the value of a budget transfer. -} - { btVal : Decimal, btType : BudgetTransferType } + { btVal : Double, btType : BudgetTransferType } let BudgetTransfer = {- @@ -984,7 +986,6 @@ in { CurID , WeekdayPat , CronPat , DatePat - , Decimal , TxOpts , StatementParser , StatementParser_ diff --git a/dhall/common.dhall b/dhall/common.dhall index e9a7d34..b8c96d0 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -4,19 +4,6 @@ let List/map = let T = ./Types.dhall -let dec = - \(s : Bool) -> - \(w : Natural) -> - \(d : Natural) -> - \(p : Natural) -> - { whole = w, decimal = d, precision = p, sign = s } : T.Decimal - -let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2 - -let d = dec2 True - -let d_ = dec2 False - let nullSplit = \(a : T.EntryAcntGetter) -> \(c : T.EntryCurGetter) -> @@ -99,7 +86,7 @@ let mRngYMD = \(r : Natural) -> T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r } -let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text } +let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text } let partN = \(c : T.EntryCurGetter) -> @@ -184,9 +171,5 @@ in { nullSplit , mvDenP , mvDenN , PartSplit - , d - , d_ - , dec - , dec2 } /\ T diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 11bb000..dda0baf 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -194,11 +194,18 @@ updateCurrencies cs = do return $ currencyMap curs currency2Record :: Currency -> Entity CurrencyR -currency2Record c@Currency {curSymbol, curFullname} = - Entity (toKey c) $ CurrencyR curSymbol curFullname +currency2Record c@Currency {curSymbol, curFullname, curPrecision} = + Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) currencyMap :: [Entity CurrencyR] -> CurrencyMap -currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e)) +currencyMap = + M.fromList + . fmap + ( \e -> + ( currencyRSymbol $ entityVal e + , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e) + ) + ) updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap updateTags cs = do diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 13a9cf9..5d7a866 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -8,7 +8,7 @@ import Data.Hashable import Database.Persist.Class import Database.Persist.Sql hiding (Single, Statement) import Internal.Statement -import Internal.Types hiding (sign) +import Internal.Types hiding (CurrencyM, sign) import Internal.Utils import RIO hiding (to) import qualified RIO.List as L @@ -134,7 +134,8 @@ insertBudget res2 <- expandTransfers key bgtLabel bgtTransfers unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $ \txs -> do - unlessLefts (addShadowTransfers bgtShadowTransfers txs) $ \shadow -> do + m <- lift $ askDBState kmCurrency + unlessLefts (addShadowTransfers m bgtShadowTransfers txs) $ \shadow -> do let bals = balanceTransfers $ txs ++ shadow concat <$> mapM insertBudgetTx bals where @@ -169,21 +170,24 @@ sortAllo a@Allocation {alloAmts = as} = do -- TODO this is going to be O(n*m), which might be a problem? addShadowTransfers - :: [ShadowTransfer] + :: CurrencyMap + -> [ShadowTransfer] -> [UnbalancedTransfer] -> EitherErrs [UnbalancedTransfer] -addShadowTransfers ms txs = +addShadowTransfers cm ms txs = fmap catMaybes $ - concatEitherL $ - fmap (uncurry fromShadow) $ + concatEithersL $ + fmap (uncurry (fromShadow cm)) $ [(t, m) | t <- txs, m <- ms] fromShadow - :: UnbalancedTransfer + :: CurrencyMap + -> UnbalancedTransfer -> ShadowTransfer - -> EitherErr (Maybe UnbalancedTransfer) -fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do + -> EitherErrs (Maybe UnbalancedTransfer) +fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do res <- shadowMatches (stMatch t) tx + v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio return $ if not res then Nothing @@ -196,11 +200,11 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stTyp , cbtCur = stCurrency , cbtFrom = stFrom , cbtTo = stTo - , cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx) + , cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx) , cbtDesc = stDesc } -shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool +shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErrs Bool shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do valRes <- valMatches tmVal $ cvValue $ cbtValue tx return $ @@ -274,30 +278,32 @@ insertIncome Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do -- TODO check that the other accounts are not income somewhere here fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom - case fromRes of - Left e -> return $ Left [e] + precRes <- lift $ lookupCurrencyPrec incCurrency + case concatEithers2 fromRes precRes (,) of + Left e -> return $ Left e -- TODO this will scan the interval allocations fully each time -- iteration which is a total waste, but the fix requires turning this -- loop into a fold which I don't feel like doing now :( - Right _ -> fmap concat <$> withDates incWhen (return . allocate) + Right (_, p) -> + let gross = roundPrecision p incGross + in fmap concat <$> withDates incWhen (return . allocate p gross) where meta = BudgetMeta key name - gross = dec2Rat incGross flatPre = concatMap flattenAllo incPretax flatTax = concatMap flattenAllo incTaxes flatPost = concatMap flattenAllo incPosttax sumAllos = sum . fmap faValue -- TODO ensure these are all the "correct" accounts - allocate day = + allocate precision gross day = let (preDeductions, pre) = - allocatePre gross $ + allocatePre precision gross $ flatPre ++ concatMap (selectAllos day) intPre tax = - allocateTax gross preDeductions $ + allocateTax precision gross preDeductions $ flatTax ++ concatMap (selectAllos day) intTax aftertaxGross = sumAllos $ tax ++ pre post = - allocatePost aftertaxGross $ + allocatePost precision aftertaxGross $ flatPost ++ concatMap (selectAllos day) intPost balance = aftertaxGross - sumAllos post bal = @@ -315,15 +321,19 @@ insertIncome else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post) allocatePre - :: Rational + :: Natural + -> Rational -> [FlatAllocation PretaxValue] -> (M.Map T.Text Rational, [FlatAllocation Rational]) -allocatePre gross = L.mapAccumR go M.empty +allocatePre precision gross = L.mapAccumR go M.empty where go m f@FlatAllocation {faValue} = let c = preCategory faValue - p = dec2Rat $ preValue faValue - v = if prePercent faValue then p * gross else p + p = preValue faValue + v = + if prePercent faValue + then roundPrecision 3 p * gross + else roundPrecision precision p in (mapAdd_ c v m, f {faValue = v}) allo2Trans @@ -344,34 +354,36 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = } allocateTax - :: Rational + :: Natural + -> Rational -> M.Map T.Text Rational -> [FlatAllocation TaxValue] -> [FlatAllocation Rational] -allocateTax gross deds = fmap (fmap go) +allocateTax precision gross deds = fmap (fmap go) where go TaxValue {tvCategories, tvMethod} = let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories) in case tvMethod of - TMPercent p -> dec2Rat p * agi + TMPercent p -> roundPrecision 3 p * agi TMBracket TaxProgression {tpDeductible, tpBrackets} -> - foldBracket (agi - dec2Rat tpDeductible) tpBrackets + foldBracket precision (agi - roundPrecision precision tpDeductible) tpBrackets allocatePost - :: Rational + :: Natural + -> Rational -> [FlatAllocation PosttaxValue] -> [FlatAllocation Rational] -allocatePost aftertax = fmap (fmap go) +allocatePost precision aftertax = fmap (fmap go) where go PosttaxValue {postValue, postPercent} = - let v = dec2Rat postValue in if postPercent then aftertax * v else v + let v = postValue in if postPercent then aftertax * roundPrecision 3 v else roundPrecision precision v -foldBracket :: Rational -> [TaxBracket] -> Rational -foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs +foldBracket :: Natural -> Rational -> [TaxBracket] -> Rational +foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs where go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) = - let l = dec2Rat tbLowerLimit - p = dec2Rat tbPercent + let l = roundPrecision precision tbLowerLimit + p = roundPrecision 3 tbPercent in if remain < l then (acc + p * (remain - l), l) else (acc, remain) data FlatAllocation v = FlatAllocation @@ -418,39 +430,46 @@ expandTransfers key name ts = do txs <- mapM (expandTransfer key name) ts return $ L.sortOn cbtWhen . concat <$> concatEithersL txs +initialCurrency :: BudgetCurrency -> CurID +initialCurrency (NoX c) = c +initialCurrency (X Exchange {xFromCur = c}) = c + expandTransfer :: MonadFinance m => CommitRId -> T.Text -> BudgetTransfer -> SqlPersistT m (EitherErrs [UnbalancedTransfer]) -expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = - -- whenHash CTExpense t (Right []) $ \key -> - fmap (fmap concat . concatEithersL) $ - forM transAmounts $ - \Amount - { amtWhen = pat - , amtValue = BudgetTransferValue {btVal = v, btType = y} - , amtDesc = desc - } -> - do - withDates pat $ \day -> - let meta = - BudgetMeta - { bmCommit = key - , bmName = name - } - tx = - FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtCur = transCurrency - , cbtFrom = transFrom - , cbtTo = transTo - , cbtValue = UnbalancedValue y $ dec2Rat v - , cbtDesc = desc - } - in return $ Right tx +expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do + pRes <- lift $ lookupCurrencyPrec $ initialCurrency transCurrency + case pRes of + Left es -> return $ Left es + Right p -> + fmap (fmap concat . concatEithersL) $ + forM transAmounts $ + \Amount + { amtWhen = pat + , amtValue = BudgetTransferValue {btVal = v, btType = y} + , amtDesc = desc + } -> + do + withDates pat $ \day -> + let meta = + BudgetMeta + { bmCommit = key + , bmName = name + } + tx = + FlatTransfer + { cbtMeta = meta + , cbtWhen = day + , cbtCur = transCurrency + , cbtFrom = transFrom + , cbtTo = transTo + , cbtValue = UnbalancedValue y $ roundPrecision p v + , cbtDesc = desc + } + in return $ Right tx insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError] insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do @@ -481,7 +500,7 @@ splitPair from to cur val = case cur of X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do let middle = TaggedAcnt xAcnt [] res1 <- pair xFromCur from middle val - res2 <- pair xToCur middle to (val * dec2Rat xRate) + res2 <- pair xToCur middle to (val * roundPrecision 3 xRate) return $ concatEithers2 res1 res2 $ \a b -> (a, Just b) where pair curid from_ to_ v = do @@ -502,19 +521,19 @@ checkAcntType :: MonadFinance m => AcntType -> AcntID - -> m (EitherErr AcntID) + -> m (EitherErrs AcntID) checkAcntType t = checkAcntTypes (t :| []) checkAcntTypes :: MonadFinance m => NE.NonEmpty AcntType -> AcntID - -> m (EitherErr AcntID) + -> m (EitherErrs AcntID) checkAcntTypes ts i = (go =<<) <$> lookupAccountType i where go t | t `L.elem` ts = Right i - | otherwise = Left $ AccountError i ts + | otherwise = Left [AccountError i ts] -------------------------------------------------------------------------------- -- statements @@ -536,12 +555,12 @@ insertManual } = do whenHash CTManual m [] $ \c -> do bounds <- lift $ askDBState kmStatementInterval - -- let days = expandDatePat bounds dp + precRes <- lift $ lookupCurrencyPrec u es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do - let v = dec2Rat amtValue let dayRes = expandDatePat bounds amtWhen - unlessLefts dayRes $ \days -> do - let tx day = txPair day from to u v amtDesc + -- TODO rounding too often + unlessLefts (concatEithers2 dayRes precRes (,)) $ \(days, p) -> do + let tx day = txPair day from to u (roundPrecision p amtValue) amtDesc txRes <- mapM (lift . tx) days unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c) return $ concat es @@ -601,13 +620,13 @@ resolveTx t@Tx {txSplits = ss} = do resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit) resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do aid <- lookupAccountKey eAcnt - cid <- lookupCurrency eCurrency + cid <- lookupCurrencyKey eCurrency sign <- lookupAccountSign eAcnt tags <- mapM lookupTag eTags -- TODO correct sign here? -- TODO lenses would be nice here return $ - concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $ + concatEithers2 (concatEithers3 aid cid sign (,,)) (concatEithersL tags) $ \(aid_, cid_, sign_) tags_ -> s { eAcnt = aid_ @@ -627,22 +646,28 @@ insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do mapM_ (insert_ . TagRelationR k) eTags return k -lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType)) +lookupAccount :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR, AcntSign, AcntType)) lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount -lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR)) +lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR)) lookupAccountKey = fmap (fmap fstOf3) . lookupAccount -lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign) +lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErrs AcntSign) lookupAccountSign = fmap (fmap sndOf3) . lookupAccount -lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType) +lookupAccountType :: MonadFinance m => AcntID -> m (EitherErrs AcntType) lookupAccountType = fmap (fmap thdOf3) . lookupAccount -lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR)) +lookupCurrency :: MonadFinance m => T.Text -> m (EitherErrs (Key CurrencyR, Natural)) lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency -lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR)) +lookupCurrencyKey :: MonadFinance m => AcntID -> m (EitherErrs (Key CurrencyR)) +lookupCurrencyKey = fmap (fmap fst) . lookupCurrency + +lookupCurrencyPrec :: MonadFinance m => AcntID -> m (EitherErrs Natural) +lookupCurrencyPrec = fmap (fmap snd) . lookupCurrency + +lookupTag :: MonadFinance m => TagID -> m (EitherErrs (Key TagR)) lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag -- TODO this hashes twice (not that it really matters) diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index aeaf133..c6496bb 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -23,11 +23,12 @@ readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx]) readImport Statement {..} = do let ores = plural $ compileOptions stmtTxOpts let cres = concatEithersL $ compileMatch <$> stmtParsers + m <- askDBState kmCurrency case concatEithers2 ores cres (,) of Right (compiledOptions, compiledMatches) -> do ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths case concatEitherL ires of - Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records + Right records -> return $ runReader (matchRecords compiledMatches $ L.sort $ concat records) m Left es -> return $ Left es Left es -> return $ Left es @@ -62,15 +63,17 @@ parseTxRecord p TxOpts {..} r = do d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d return $ Just $ TxRecord d' a e os p -matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx] +matchRecords :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs [BalTx]) matchRecords ms rs = do - (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs - case (matched, unmatched, notfound) of - (ms_, [], []) -> do - -- TODO record number of times each match hits for debugging - matched_ <- first (: []) $ mapM balanceTx ms_ - Right matched_ - (_, us, ns) -> Left [StatementError us ns] + res <- matchAll (matchPriorities ms) rs + case res of + Left es -> return $ Left es + Right (matched, unmatched, notfound) -> do + case (matched, unmatched, notfound) of + (ms_, [], []) -> do + -- TODO record number of times each match hits for debugging + return $ first (: []) $ mapM balanceTx ms_ + (_, us, ns) -> return $ Left [StatementError us ns] matchPriorities :: [MatchRe] -> [MatchGroup] matchPriorities = @@ -124,28 +127,38 @@ zipperSlice f x = go EQ -> goEq $ Unzipped bs (a : cs) as LT -> z -zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx) +zipperMatch + :: Unzipped MatchRe + -> TxRecord + -> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx)) zipperMatch (Unzipped bs cs as) x = go [] cs where - go _ [] = Right (Zipped bs $ cs ++ as, MatchFail) + go _ [] = return $ Right (Zipped bs $ cs ++ as, MatchFail) go prev (m : ms) = do res <- matches m x case res of - MatchFail -> go (m : prev) ms - skipOrPass -> + Right MatchFail -> go (m : prev) ms + Right skipOrPass -> let ps = reverse prev ms' = maybe ms (: ms) (matchDec m) - in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass) + in return $ Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass) + Left es -> return $ Left es -zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx) +-- TODO all this unpacking left/error crap is annoying +zipperMatch' + :: Zipped MatchRe + -> TxRecord + -> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx)) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do res <- matches a x case res of - MatchFail -> go (Zipped (a : bs) as) - skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) - go z' = Right (z', MatchFail) + Right MatchFail -> go (Zipped (a : bs) as) + Right skipOrPass -> + return $ Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) + Left es -> return $ Left es + go z' = return $ Right (z', MatchFail) matchDec :: MatchRe -> Maybe MatchRe matchDec m = case spTimes m of @@ -153,59 +166,76 @@ matchDec m = case spTimes m of Just n -> Just $ m {spTimes = Just $ n - 1} Nothing -> Just m -matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchAll :: [MatchGroup] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe])) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of - (_, []) -> return (matched, [], unused) - ([], _) -> return (matched, rs, unused) + (_, []) -> return $ Right (matched, [], unused) + ([], _) -> return $ Right (matched, rs, unused) (g : gs', _) -> do - (ts, unmatched, us) <- matchGroup g rs - go (ts ++ matched, us ++ unused) gs' unmatched + res <- matchGroup g rs + case res of + Right (ts, unmatched, us) -> + go (ts ++ matched, us ++ unused) gs' unmatched + Left es -> return $ Left es -matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchGroup :: MatchGroup -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe])) matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do - (md, rest, ud) <- matchDates ds rs - (mn, unmatched, un) <- matchNonDates ns rest - return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) + res <- matchDates ds rs + case res of + Left es -> return $ Left es + Right (md, rest, ud) -> do + res' <- matchNonDates ns rest + case res' of + Right (mn, unmatched, un) -> do + return $ Right $ (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) + Left es -> return $ Left es -matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe])) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = - Right - ( catMaybes matched - , reverse unmatched - , recoverZipper z - ) + return $ + Right + ( catMaybes matched + , reverse unmatched + , recoverZipper z + ) go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of Left zipped -> go (matched, r : unmatched, zipped) rs Right unzipped -> do - (z', res) <- zipperMatch unzipped r - let (m, u) = case res of - MatchPass p -> (Just p : matched, unmatched) - MatchSkip -> (Nothing : matched, unmatched) - MatchFail -> (matched, r : unmatched) - go (m, u, z') rs + res <- zipperMatch unzipped r + case res of + Right (z', res') -> do + let (m, u) = case res' of + (MatchPass p) -> (Just p : matched, unmatched) + MatchSkip -> (Nothing : matched, unmatched) + MatchFail -> (matched, r : unmatched) + go (m, u, z') rs + Left es -> return $ Left es findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m -matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchNonDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe])) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = - Right - ( catMaybes matched - , reverse unmatched - , recoverZipper z - ) + return $ + Right + ( catMaybes matched + , reverse unmatched + , recoverZipper z + ) go (matched, unmatched, z) (r : rs) = do - (z', res) <- zipperMatch' z r - let (m, u) = case res of - MatchPass p -> (Just p : matched, unmatched) - MatchSkip -> (Nothing : matched, unmatched) - MatchFail -> (matched, r : unmatched) - in go (m, u, resetZipper z') rs + res <- zipperMatch' z r + case res of + Left es -> return $ Left es + Right (z', res') -> do + let (m, u) = case res' of + MatchPass p -> (Just p : matched, unmatched) + MatchSkip -> (Nothing : matched, unmatched) + MatchFail -> (matched, r : unmatched) + in go (m, u, resetZipper z') rs balanceTx :: RawTx -> EitherErr BalTx balanceTx t@Tx {txSplits = ss} = do diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index d76f539..d8f05c1 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -5,6 +5,7 @@ module Internal.Types where +-- import Control.Monad.Except import Data.Fix (Fix (..), foldFix) import Data.Functor.Foldable (embed) import qualified Data.Functor.Foldable.TH as TH @@ -49,7 +50,6 @@ makeHaskellTypesWith , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" - , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal" , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type" , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" @@ -96,7 +96,6 @@ deriveProduct , "DateMatcher" , "ValMatcher" , "YMDMatcher" - , "Decimal" , "BudgetCurrency" , "Exchange" , "EntryNumGetter" @@ -180,6 +179,12 @@ deriving instance Hashable DatePat type BudgetTransfer = Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue +deriving instance Hashable BudgetTransfer + +deriving instance Generic BudgetTransfer + +deriving instance FromDhall BudgetTransfer + data Budget = Budget { bgtLabel :: Text , bgtIncomes :: [Income] @@ -215,7 +220,7 @@ deriving instance Ord TaggedAcnt type CurID = T.Text data Income = Income - { incGross :: Decimal + { incGross :: Double , incCurrency :: CurID , incWhen :: DatePat , incPretax :: [SingleAllocation PretaxValue] @@ -231,9 +236,11 @@ deriving instance (Ord w, Ord v) => Ord (Amount w v) deriving instance Generic (Amount w v) -deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v) +deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v) -deriving instance (Generic w, Generic v, Hashable w, Hashable v) => 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) @@ -280,11 +287,7 @@ data Transfer a c w v = Transfer , transAmounts :: [Amount w v] , transCurrency :: c } - deriving (Eq, Show, Generic, FromDhall) - -deriving instance - (Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v) - => Hashable (Transfer a c w v) + deriving (Eq, Show) deriving instance Hashable ShadowTransfer @@ -298,10 +301,6 @@ deriving instance Hashable YMDMatcher deriving instance Hashable DateMatcher -deriving instance Ord Decimal - -deriving instance Hashable Decimal - -- TODO this just looks silly...but not sure how to simplify it instance Ord YMDMatcher where compare (Y y) (Y y') = compare y y' @@ -394,12 +393,18 @@ type AcntID = T.Text type TagID = T.Text -type HistTransfer = Transfer AcntID CurID DatePat Decimal +type HistTransfer = Transfer AcntID CurID DatePat Double + +deriving instance Generic HistTransfer + +deriving instance Hashable HistTransfer + +deriving instance FromDhall HistTransfer data History = HistTransfer !HistTransfer | HistStatement !Statement - deriving (Eq, Hashable, Generic, FromDhall) + deriving (Eq, Generic, Hashable, FromDhall) type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID @@ -517,6 +522,7 @@ CommitR sql=commits CurrencyR sql=currencies symbol T.Text fullname T.Text + precision Int deriving Show Eq TagR sql=tags symbol T.Text @@ -579,7 +585,7 @@ instance PersistField ConfigType where type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) -type CurrencyMap = M.Map CurID CurrencyRId +type CurrencyMap = M.Map CurID (CurrencyRId, Natural) type TagMap = M.Map TagID TagRId @@ -593,6 +599,8 @@ data DBState = DBState , kmConfigDir :: !FilePath } +type CurrencyM = Reader CurrencyMap + type MappingT m = ReaderT DBState (SqlPersistT m) type KeySplit = Entry AccountRId Rational CurrencyRId TagRId @@ -746,6 +754,10 @@ type EitherErr = Either InsertError type EitherErrs = Either [InsertError] +-- type InsertExceptT m = ExceptT [InsertError] m + +-- type InsertExcept = InsertExceptT Identity + data XGregorian = XGregorian { xgYear :: !Int , xgMonth :: !Int diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index ddfb701..9f25089 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -8,7 +8,6 @@ module Internal.Utils , resolveBounds , resolveBounds_ , leftToMaybe - , dec2Rat , concatEithers2 , concatEithers3 , concatEither3 @@ -37,9 +36,12 @@ module Internal.Utils , compileOptions , dateMatches , valMatches + , roundPrecision + , roundPrecisionCur ) where +import Control.Monad.Reader import Data.Time.Format.ISO8601 import GHC.Real import Internal.Types @@ -153,28 +155,34 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d) -------------------------------------------------------------------------------- -- matching -matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx) +matches :: MatchRe -> TxRecord -> CurrencyM (EitherErrs (MatchRes RawTx)) matches StatementParser {spTx, spOther, spVal, spDate, spDesc} r@TxRecord {trDate, trAmount, trDesc, trOther} = do - res <- concatEither3 val other desc $ \x y z -> x && y && z - if date && res - then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx - else Right MatchFail + let res = concatEithers3 val other desc $ \x y z -> x && y && z && date + case res of + Right test + | test -> maybe (return $ Right MatchSkip) convert spTx + | otherwise -> return $ Right MatchFail + Left es -> return $ Left es where val = valMatches spVal trAmount date = maybe True (`dateMatches` trDate) spDate other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther desc = maybe (return True) (matchMaybe trDesc . snd) spDesc - convert (TxGetter cur a ss) = toTx cur a ss r + convert (TxGetter cur a ss) = do + res <- toTx cur a ss r + return $ fmap MatchPass res -toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> EitherErrs RawTx -toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = - concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> +toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> CurrencyM (EitherErrs RawTx) +toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do + m <- ask + let ssRes = concatEithersL $ fmap (resolveEntry m r) toSplits + return $ concatEithers2 acRes ssRes $ \(a, c) ss -> let fromSplit = Entry - { eAcnt = a_ - , eCurrency = c_ + { eAcnt = a + , eCurrency = c , eValue = Just trAmount , eComment = "" , eTags = [] -- TODO what goes here? @@ -182,15 +190,14 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = in Tx { txDate = trDate , txDescr = trDesc - , txSplits = fromSplit : ss_ + , txSplits = fromSplit : ss } where acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,) - ssRes = concatEithersL $ fmap (resolveSplit r) toSplits -valMatches :: ValMatcher -> Rational -> EitherErr Bool +valMatches :: ValMatcher -> Rational -> EitherErrs Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x - | Just d_ <- vmDen, d_ >= p = Left $ MatchValPrecisionError d_ p + | Just d_ <- vmDen, d_ >= p = Left [MatchValPrecisionError d_ p] | otherwise = Right $ checkMaybe (s ==) vmSign @@ -205,26 +212,33 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x dateMatches :: DateMatcher -> Day -> Bool dateMatches md = (EQ ==) . compareDate md -otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErr Bool +otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErrs Bool otherMatches dict m = case m of Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n) Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n where lookup_ t n = lookupErr (MatchField t) n dict -resolveSplit :: TxRecord -> EntryGetter -> EitherErrs RawSplit -resolveSplit r s@Entry {eAcnt, eValue, eCurrency} = - concatEithers2 acRes valRes $ - \(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_}) +resolveEntry :: CurrencyMap -> TxRecord -> EntryGetter -> EitherErrs RawSplit +resolveEntry m r s@Entry {eAcnt, eValue, eCurrency} = do + (a, c, v) <- concatEithers2 acRes valRes $ \(a, c) v -> (a, c, v) + v' <- mapM (roundPrecisionCur c m) v + return $ + s + { eAcnt = a + , eValue = v' + , eCurrency = c + } where acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,) - valRes = plural $ mapM (resolveValue r) eValue + valRes = mapM (resolveValue r) eValue -resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational +resolveValue :: TxRecord -> EntryNumGetter -> EitherErrs Double resolveValue r s = case s of - (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r) - (ConstN c) -> Right $ dec2Rat c - AmountN -> Right $ trAmount r + (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r) + (ConstN c) -> Right c + -- TODO don't coerce to rational in trAmount + AmountN -> Right $ fromRational $ trAmount r resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text resolveAcnt = resolveSplitField AcntField @@ -235,21 +249,21 @@ resolveCurrency = resolveSplitField CurField resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text resolveSplitField t TxRecord {trOther = o} s = case s of ConstT p -> Right p - LookupT f -> plural $ lookup_ f o - MapT (Field f m) -> plural $ do + LookupT f -> lookup_ f o + MapT (Field f m) -> do k <- lookup_ f o lookup_ k m Map2T (Field (f1, f2) m) -> do - (k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,) - plural $ lookup_ (k1, k2) m + (k1, k2) <- concatEithers2 (lookup_ f1 o) (lookup_ f2 o) (,) + lookup_ (k1, k2) m where - lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v + lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErrs v lookup_ = lookupErr (SplitIDField t) -lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v +lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErrs v lookupErr what k m = case M.lookup k m of Just x -> Right x - _ -> Left $ LookupError what $ showT k + _ -> Left [LookupError what $ showT k] parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational parseRational (pat, re) s = case matchGroupsMaybe s re of @@ -278,7 +292,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of k <- readSign sign return (k, w) -readRational :: T.Text -> EitherErr Rational +readDouble :: T.Text -> EitherErrs Double +readDouble s = case readMaybe $ T.unpack s of + Just x -> Right x + Nothing -> Left [ConversionError s] + +readRational :: T.Text -> EitherErrs Rational readRational s = case T.split (== '.') s of [x] -> maybe err (return . fromInteger) $ readT x [x, y] -> case (readT x, readT y) of @@ -290,7 +309,7 @@ readRational s = case T.split (== '.') s of _ -> err where readT = readMaybe . T.unpack - err = Left $ ConversionError s + err = Left [ConversionError s] -- TODO smells like a lens -- mapTxSplits :: (a -> b) -> Tx a -> Tx b @@ -307,11 +326,22 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] txt = T.pack . show pad i c z = T.append (T.replicate (i - T.length z) c) z -dec2Rat :: Decimal -> Rational -dec2Rat D {sign, whole, decimal, precision} = - k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision))) +roundPrecision :: Natural -> Double -> Rational +roundPrecision n = (% p) . round . (* fromIntegral p) . toRational where - k = if sign then 1 else -1 + p = 10 ^ n + +roundPrecisionCur :: CurID -> CurrencyMap -> Double -> EitherErrs Rational +roundPrecisionCur c m x = + case M.lookup c m of + Just (_, n) -> Right $ roundPrecision n x + Nothing -> Left undefined + +-- dec2Rat :: Decimal -> Rational +-- dec2Rat D {sign, whole, decimal, precision} = +-- k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision))) +-- where +-- k = if sign then 1 else -1 acntPath2Text :: AcntPath -> T.Text acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) @@ -640,10 +670,10 @@ compileRegex groups pat = case res of (blankExecOpt {captureGroups = groups}) pat -matchMaybe :: T.Text -> Regex -> EitherErr Bool +matchMaybe :: T.Text -> Regex -> EitherErrs Bool matchMaybe q re = case execute re q of Right res -> Right $ isJust res - Left _ -> Left $ RegexError "this should not happen" + Left _ -> Left [RegexError "this should not happen"] matchGroupsMaybe :: T.Text -> Regex -> [T.Text] matchGroupsMaybe q re = case regexec re q of