ENH store account sign in db itself

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
 

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"

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

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)
+              [ ("start", Just $ tshow s)
-              , ("by", Just $ showT b)
+              , ("by", Just $ tshow b)
-              , ("repeats", showT <$> r)
+              , ("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
+tshowx :: TxRecord -> T.Text
-showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
+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)
+      , ("counter", Just $ maybe "Inf" tshow spTimes)
-      , ("priority", Just $ showT spPriority)
+      , ("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)
+      , ("numerator", tshow <$> vmNum)
-      , ("denominator", showT <$> vmDen)
+      , ("denominator", tshow <$> vmDen)
-      , ("precision", Just $ showT vmPrec)
+      , ("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
+lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
-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 = lookupFinance AcntField kmAccount
 
 lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
-lookupAccountKey = fmap fstOf3 . lookupAccount
+lookupAccountKey = fmap fst . lookupAccount
-
-lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
-lookupAccountSign = fmap sndOf3 . 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 () TagRId
-  -> [Entry (AccountRId, AcntSign) LinkDeferred 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 () TagRId
-  -> [Entry (AccountRId, AcntSign) v 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
+balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
-  let s = fromIntegral $ sign2Int sign
   (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 $
+  combineError acntRes tagRes $ \a ts -> e {eAcnt = a, eTags = ts}
-    \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
 
 findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
 findBalance k e = do