From c8f7689c7a40e251b2e1a9d2bea3931a1af43cf1 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 9 Jul 2023 11:13:35 -0400 Subject: [PATCH] ENH store account sign in db itself --- lib/Internal/Database.hs | 8 +-- lib/Internal/Types/Database.hs | 19 ++++++- lib/Internal/Types/Main.hs | 5 +- lib/Internal/Utils.hs | 98 +++++++++++++--------------------- 4 files changed, 60 insertions(+), 70 deletions(-) diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 2ede03c..62ed6eb 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -201,7 +201,7 @@ toKey = toSqlKey . fromIntegral . hash tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h) $ - AccountR name (toPath parents) des + AccountR name (toPath parents) des (accountSign t) where p = AcntPath t (reverse (name : parents)) h = hash p @@ -210,7 +210,7 @@ tree2Entity t parents name des = tree2Records :: AcntType -> AccountTree - -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))]) + -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))]) tree2Records t = go [] where go ps (Placeholder d n cs) = @@ -225,10 +225,10 @@ tree2Records t = go [] k = entityKey e in ( [acnt k n (fmap snd ps) d] , expand k $ fmap fst ps - , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))] + , [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))] ) toPath = T.intercalate "/" . (atName t :) . reverse - acnt k n ps = Entity k . AccountR n (toPath ps) + acnt k n ps desc = Entity k $ AccountR n (toPath ps) desc sign expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..] sign = accountSign t diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index b3f4564..1d4be04 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -34,6 +34,7 @@ AccountR sql=accounts name T.Text fullpath T.Text desc T.Text + sign AcntSign deriving Show Eq AccountPathR sql=account_paths parent AccountRId OnDeleteCascade @@ -78,7 +79,21 @@ instance PersistFieldSql ConfigType where instance PersistField ConfigType where toPersistValue = PersistText . T.pack . show - -- TODO these error messages *might* be good enough? fromPersistValue (PersistText v) = maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v - fromPersistValue _ = Left "wrong type" + fromPersistValue _ = Left "not a string" + +data AcntSign = Credit | Debit + deriving (Show, Eq, Ord) + +instance PersistFieldSql AcntSign where + sqlType _ = SqlInt64 + +instance PersistField AcntSign where + toPersistValue Debit = PersistInt64 1 + toPersistValue Credit = PersistInt64 (-1) + + fromPersistValue (PersistInt64 1) = Right Debit + fromPersistValue (PersistInt64 (-1)) = Right Credit + fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v + fromPersistValue _ = Left "not an Int64" diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 7ac50db..2e36bc2 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -35,7 +35,7 @@ data ConfigHashes = ConfigHashes , chImport :: ![Int] } -type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) +type AccountMap = M.Map AcntID (AccountRId, AcntType) data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision} deriving (Show) @@ -186,9 +186,6 @@ data Keyed a = Keyed data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) -data AcntSign = Credit | Debit - deriving (Show) - -- TODO debit should be negative sign2Int :: AcntSign -> Int sign2Int Debit = 1 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 32cd18f..e5758be 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -30,19 +30,15 @@ module Internal.Utils , mapErrorsPooledIO , showError , acntPath2Text - , showT + , tshow , lookupErr , gregorians , uncurry3 - , fstOf3 - , sndOf3 - , thdOf3 , xGregToDay , dateMatches , valMatches , lookupAccount , lookupAccountKey - , lookupAccountSign , lookupAccountType , lookupCurrency , lookupCurrencyKey @@ -410,7 +406,7 @@ collectErrorsIO = mapErrorsIO id lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v lookupErr what k m = case M.lookup k m of Just x -> return x - _ -> throwError $ InsertException [LookupError what $ showT k] + _ -> throwError $ InsertException [LookupError what $ tshow k] fmtRational :: Natural -> Rational -> T.Text fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] @@ -439,7 +435,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) showError :: InsertError -> [T.Text] showError other = case other of - (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms) + (StatementError ts ms) -> (tshowx <$> ts) ++ (showMatch <$> ms) (DaySpanError a b) -> [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]] where @@ -461,9 +457,9 @@ showError other = case other of keyVals $ [ (k, v) | (k, Just v) <- - [ ("start", Just $ showT s) - , ("by", Just $ showT b) - , ("repeats", showT <$> r) + [ ("start", Just $ tshow s) + , ("by", Just $ tshow b) + , ("repeats", tshow <$> r) ] ] msg = case p of @@ -474,7 +470,7 @@ showError other = case other of (InsertIOError msg) -> [T.append "IO Error: " msg] (ParseError msg) -> [T.append "Parse Error: " msg] (MatchValPrecisionError d p) -> - [T.unwords ["Match denominator", showT d, "must be less than", showT p]] + [T.unwords ["Match denominator", tshow d, "must be less than", tshow p]] (LookupError t f) -> [T.unwords ["Could not find field", f, "when resolving", what]] where @@ -494,27 +490,27 @@ showError other = case other of [ "Income allocations for budget" , singleQuote name , "exceed total on day" - , showT day + , tshow day , "where balance is" - , showT (fromRational balance :: Double) + , tshow (fromRational balance :: Double) ] ] (PeriodError start next) -> [ T.unwords [ "First pay period on " - , singleQuote $ showT start + , singleQuote $ tshow start , "must start before first income payment on " - , singleQuote $ showT next + , singleQuote $ tshow next ] ] (IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) -> [ T.unwords [ "No credit entry for index" - , singleQuote $ showT lngIndex + , singleQuote $ tshow lngIndex , "for entry with account" , singleQuote eAcnt , "on" - , showT day + , tshow day ] ] (RoundError cur) -> @@ -525,15 +521,15 @@ showError other = case other of ] showGregorian_ :: Gregorian -> T.Text -showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] +showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay] -showTx :: TxRecord -> T.Text -showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = +tshowx :: TxRecord -> T.Text +tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = T.append "Unmatched transaction: " $ keyVals [ ("path", T.pack f) , ("date", T.pack $ iso8601Show d) - , ("value", showT v) + , ("value", tshow v) , ("description", doubleQuote e) ] @@ -546,8 +542,8 @@ showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} , ("val", showValMatcher spVal) , ("desc", fst <$> spDesc) , ("other", others) - , ("counter", Just $ maybe "Inf" showT spTimes) - , ("priority", Just $ showT spPriority) + , ("counter", Just $ maybe "Inf" tshow spTimes) + , ("priority", Just $ tshow spPriority) ] others = case spOther of [] -> Nothing @@ -580,7 +576,7 @@ showYMDMatcher = showYMD_ . fromYMDMatcher showYMD_ :: YMD_ -> T.Text showYMD_ md = - T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*") + T.intercalate "-" $ L.take 3 (fmap tshow digits ++ L.repeat "*") where digits = case md of Y_ y -> [fromIntegral y] @@ -594,9 +590,9 @@ showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} = where kvs = [ ("sign", (\s -> if s then "+" else "-") <$> vmSign) - , ("numerator", showT <$> vmNum) - , ("denominator", showT <$> vmDen) - , ("precision", Just $ showT vmPrec) + , ("numerator", tshow <$> vmNum) + , ("denominator", tshow <$> vmDen) + , ("precision", Just $ tshow vmPrec) ] showMatchOther :: FieldMatcherRe -> T.Text @@ -622,9 +618,6 @@ keyVal a b = T.concat [a, "=", b] keyVals :: [(T.Text, T.Text)] -> T.Text keyVals = T.intercalate "; " . fmap (uncurry keyVal) -showT :: Show a => a -> T.Text -showT = T.pack . show - -------------------------------------------------------------------------------- -- random functions @@ -644,26 +637,14 @@ mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c -fstOf3 :: (a, b, c) -> a -fstOf3 (a, _, _) = a - -sndOf3 :: (a, b, c) -> b -sndOf3 (_, b, _) = b - -thdOf3 :: (a, b, c) -> c -thdOf3 (_, _, c) = c - -lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType) +lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType) lookupAccount = lookupFinance AcntField kmAccount lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId -lookupAccountKey = fmap fstOf3 . lookupAccount - -lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign -lookupAccountSign = fmap sndOf3 . lookupAccount +lookupAccountKey = fmap fst . lookupAccount lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType -lookupAccountType = fmap thdOf3 . lookupAccount +lookupAccountType = fmap snd . lookupAccount lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec lookupCurrency = lookupFinance CurField kmCurrency @@ -917,8 +898,8 @@ balanceFinal => BCKey -> Decimal -> NonEmpty InsertEntry - -> Entry (AccountRId, AcntSign) () TagRId - -> [Entry (AccountRId, AcntSign) LinkDeferred TagRId] + -> Entry AccountRId () TagRId + -> [Entry AccountRId LinkDeferred TagRId] -> StateT EntryBals m InsertEntrySet balanceFinal k@(curID, _) tot fs t0 ts = do let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs @@ -936,18 +917,17 @@ doEntries => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred)) -> BCKey -> Decimal - -> Entry (AccountRId, AcntSign) () TagRId - -> [Entry (AccountRId, AcntSign) v TagRId] + -> Entry AccountRId () TagRId + -> [Entry AccountRId v TagRId] -> StateT EntryBals m (NonEmpty InsertEntry) -doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do +doEntries f k tot e@Entry {eAcnt = acntID} es = do es' <- mapErrors (balanceEntry f k) es let e0val = tot - entrySum es' -- TODO not dry - let s = fromIntegral $ sign2Int sign -- NOTE hack modify (mapAdd_ (acntID, k) e0val) let e' = InsertEntry - { ieEntry = e {eValue = s * e0val, eAcnt = acntID} + { ieEntry = e {eValue = e0val, eAcnt = acntID} , ieDeferred = Nothing } return $ e' :| es' @@ -988,27 +968,25 @@ balanceEntry :: (MonadInsertError m) => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred)) -> BCKey - -> Entry (AccountRId, AcntSign) v TagRId + -> Entry AccountRId v TagRId -> StateT EntryBals m InsertEntry -balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do - let s = fromIntegral $ sign2Int sign +balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do (newVal, deferred) <- f (acntID, k) eValue modify (mapAdd_ (acntID, k) newVal) return $ InsertEntry - { ieEntry = e {eValue = s * newVal, eAcnt = acntID} + { ieEntry = e {eValue = newVal, eAcnt = acntID} , ieDeferred = deferred } resolveAcntAndTags :: (MonadInsertError m, MonadFinance m) => Entry AcntID v TagID - -> m (Entry (AccountRId, AcntSign) v TagRId) + -> m (Entry AccountRId v TagRId) resolveAcntAndTags e@Entry {eAcnt, eTags} = do - let acntRes = lookupAccount eAcnt + let acntRes = lookupAccountKey eAcnt let tagRes = mapErrors lookupTag eTags - combineError acntRes tagRes $ - \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags} + combineError acntRes tagRes $ \a ts -> e {eAcnt = a, eTags = ts} findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal findBalance k e = do