FIX mixed up account paths/keys

app/Main.hs

@@ -20,6 +20,7 @@ import Internal.Utils
 import Options.Applicative
 import RIO
 import RIO.FilePath
+import qualified RIO.Map as M
 import qualified RIO.Text as T
 
 main :: IO ()
@@ -232,6 +233,8 @@ runSync threads c bs hs = do
         -- TODO for some mysterious reason using multithreading just for this
         -- little bit slows the program down by several seconds
         -- lift $ setNumCapabilities threads
+        (liftIO . print) =<< askDBState (M.keys . csAccountMap)
+        -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
         (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         -- lift $ setNumCapabilities 1

lib/Internal/Database.hs

@@ -4,7 +4,7 @@ module Internal.Database
   , nukeTables
   , updateHashes
   , updateDBState
-  , getDBState
+  -- , getDBState
   , tree2Records
   , flattenAcntRoot
   , indexAcntRoot
@@ -289,22 +289,22 @@ readCurrentCommits = do
             CTTransfer -> (bs, y : ts, hs)
             CTHistory -> (bs, ts, y : hs)
 
-hashConfig :: [Budget] -> [History] -> [Int]
+-- hashConfig :: [Budget] -> [History] -> [Int]
-hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
+-- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
-  where
+--   where
-    (ms, ps) = partitionEithers $ fmap go hs
+--     (ms, ps) = partitionEithers $ fmap go hs
-    go (HistTransfer x) = Left x
+--     go (HistTransfer x) = Left x
-    go (HistStatement x) = Right x
+--     go (HistStatement x) = Right x
 
-setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
+-- setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
-setDiff2 = setDiffWith2 (==)
+-- setDiff2 = setDiffWith2 (==)
 
--- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
+-- -- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
--- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
+-- -- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
 
--- setDiff as bs = (as \\ bs, bs \\ as)
+-- -- setDiff as bs = (as \\ bs, bs \\ as)
-setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
+-- setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
-setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
+-- setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
 
 setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
 setDiffWith f = go [] []
@@ -319,8 +319,8 @@ setDiffWith f = go [] []
       | f a b = Just (b, bs)
       | otherwise = inB a bs
 
-getDBHashes :: MonadSqlQuery m => m [Int]
+-- getDBHashes :: MonadSqlQuery m => m [Int]
-getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
+-- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
 
 nukeDBHash :: MonadSqlQuery m => Int -> m ()
 nukeDBHash h = deleteE $ do
@@ -330,11 +330,11 @@ nukeDBHash h = deleteE $ do
 nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
-getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
+-- getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
-getConfigHashes bs hs = do
+-- getConfigHashes bs hs = do
-  let ch = hashConfig bs hs
+--   let ch = hashConfig bs hs
-  dh <- getDBHashes
+--   dh <- getDBHashes
-  return $ setDiff2 dh ch
+--   return $ setDiff2 dh ch
 
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
@@ -380,30 +380,32 @@ currencyMap =
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
-parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
+makeAccountEntity :: AccountR -> Entity AccountR
-parentEntity t parents name des =
+makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
-  Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False
+
+makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
+makeAccountR atype name parents des = AccountR name path des (accountSign atype)
   where
-    p = AcntPath t (name : parents)
+    path = AcntPath atype (reverse $ name : parents)
-    h = hash p
 
 tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
-      let e = parentEntity t (fmap snd ps) n d
+      let (parentKeys, parentNames) = L.unzip ps
-          k = entityKey e
+          a = acnt n parentNames d False
-          (as, aps) = L.unzip $ fmap (go ((k, n) : ps)) cs
+          k = entityKey a
-          a0 = acnt k n (fmap snd ps) d
+          thesePaths = expand k parentKeys
-          paths = expand k $ fmap fst ps
+       in bimap ((a :) . concat) ((thesePaths ++) . concat) $
-       in (a0 : concat as, paths ++ concat aps)
+            L.unzip $
+              go ((k, n) : ps) <$> cs
     go ps (Account d n) =
-      let e = parentEntity t (fmap snd ps) n d
+      let (parentKeys, parentNames) = L.unzip ps
-          k = entityKey e
+          a = acnt n parentNames d True
-       in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps)
+          k = entityKey a
-    acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True
+       in ([a], expand k parentKeys)
     expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
-    sign = accountSign t
+    acnt n ps d = makeAccountEntity . makeAccountR t n ps d
 
 accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
 accountPathRecord p c d =
@@ -415,48 +417,74 @@ paths2IDs =
     . first trimNames
     . L.unzip
     . L.sortOn fst
-    . fmap (first pathList)
+    . fmap (first (NE.reverse . acntPath2NonEmpty))
-  where
+
-    pathList (AcntPath t ns) = NE.reverse $ atName t :| reverse ns
+-- -- none of these errors should fire assuming that input is sorted and unique
+-- trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
+-- trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
+--   where
+--     trimAll _ [] = []
+--     trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
+--       (a, [], bs) -> reverse $ trim i a : bs
+--       (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
+--     matchPre i (y, ys, old) new = case (y !? i, new !? i) of
+--       (Nothing, Just _) ->
+--         case ys of
+--           [] -> (new, [], trim i y : old)
+--           _ -> err "unsorted input"
+--       (Just _, Nothing) -> err "unsorted input"
+--       (Nothing, Nothing) -> err "duplicated inputs"
+--       (Just a, Just b)
+--         | a == b -> (new, y : ys, old)
+--         | otherwise ->
+--             let next = case ys of
+--                   [] -> [trim i y]
+--                   _ -> trimAll (i + 1) (reverse $ y : ys)
+--              in (new, [], reverse next ++ old)
+--     trim i = NE.take (i + 1)
+--     err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
 
 -- none of these errors should fire assuming that input is sorted and unique
-trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
+trimNames :: [NonEmpty T.Text] -> [AcntID]
-trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
+trimNames = fmap (T.intercalate "_") . go []
   where
-    trimAll _ [] = []
+    go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
-    trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
+    go prev = concatMap (go' prev) . groupNonEmpty
-      (a, [], bs) -> reverse $ trim i a : bs
+    go' prev (key, rest) = case rest of
-      (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
+      (_ :| []) -> [key : prev]
-    matchPre i (y, ys, old) new = case (y !? i, new !? i) of
+      ([] :| xs) ->
-      (Nothing, Just _) ->
+        let next = key : prev
-        case ys of
+            other = go next $ fmap (fromMaybe undefined . NE.nonEmpty) xs
-          [] -> (new, [], trim i y : old)
+         in next : other
-          _ -> err "unsorted input"
+      (x :| xs) -> go (key : prev) $ fmap (fromMaybe undefined . NE.nonEmpty) (x : xs)
-      (Just _, Nothing) -> err "unsorted input"
-      (Nothing, Nothing) -> err "duplicated inputs"
-      (Just a, Just b)
-        | a == b -> (new, y : ys, old)
-        | otherwise ->
-            let next = case ys of
-                  [] -> [trim i y]
-                  _ -> trimAll (i + 1) (reverse $ y : ys)
-             in (new, [], reverse next ++ old)
-    trim i = NE.take (i + 1)
-    err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
 
-(!?) :: NE.NonEmpty a -> Int -> Maybe a
+groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
-xs !? n
+groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
-  | n < 0 = Nothing
+
-  -- Definition adapted from GHC.List
+-- groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, (Maybe a, [NonEmpty a]))]
-  | otherwise =
+-- groupNonEmpty = fmap (second (go <$>)) . groupWith NE.head
-      foldr
+--   where
-        ( \x r k -> case k of
+--     go xs = case NE.nonEmpty $ NE.tail xs of
-            0 -> Just x
+--       (x :| [])
-            _ -> r (k - 1)
+
-        )
+-- where
-        (const Nothing)
+--   go xs@((key :| _) :| _) = (key, xs)
-        xs
+
-        n
+-- go (x :| xs) = (x, Just xs)
+
+-- (!?) :: NE.NonEmpty a -> Int -> Maybe a
+-- xs !? n
+--   | n < 0 = Nothing
+--   -- Definition adapted from GHC.List
+--   | otherwise =
+--       foldr
+--         ( \x r k -> case k of
+--             0 -> Just x
+--             _ -> r (k - 1)
+--         )
+--         (const Nothing)
+--         xs
+--         n
 
 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
 flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
@@ -479,39 +507,39 @@ makeAcntMap =
 indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
 indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
 
-getDBState
+-- getDBState
-  :: (MonadInsertError m, MonadSqlQuery m)
+--   :: (MonadInsertError m, MonadSqlQuery m)
-  => Config
+--   => Config
-  -> [Budget]
+--   -> [Budget]
-  -> [History]
+--   -> [History]
-  -> m (DBState, DBUpdates)
+--   -> m (DBState, DBUpdates)
-getDBState c bs hs = do
+-- getDBState c bs hs = do
-  (del, new) <- getConfigHashes bs hs
+--   (del, new) <- getConfigHashes bs hs
-  combineError bi si $ \b s ->
+--   combineError bi si $ \b s ->
-    ( DBState
+--     ( DBState
-        { kmCurrency = currencyMap cs
+--         { kmCurrency = currencyMap cs
-        , kmAccount = undefined
+--         , kmAccount = undefined
-        , kmBudgetInterval = b
+--         , kmBudgetInterval = b
-        , kmStatementInterval = s
+--         , kmStatementInterval = s
-        , kmTag = tagMap ts
+--         , kmTag = tagMap ts
-        , kmNewCommits = new
+--         , kmNewCommits = new
-        }
+--         }
-    , DBUpdates
+--     , DBUpdates
-        { duOldCommits = del
+--         { duOldCommits = del
-        , duNewTagIds = ts
+--         , duNewTagIds = ts
-        , duNewAcntPaths = undefined
+--         , duNewAcntPaths = undefined
-        , duNewAcntIds = acnts
+--         , duNewAcntIds = acnts
-        , duNewCurrencyIds = cs
+--         , duNewCurrencyIds = cs
-        }
+--         }
-    )
+--     )
-  where
+--   where
-    bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
+--     bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
-    si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
+--     si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
-    (acnts, _) = indexAcntRoot $ accounts c
+--     (acnts, _) = indexAcntRoot $ accounts c
-    cs = currency2Record <$> currencies c
+--     cs = currency2Record <$> currencies c
-    ts = toRecord <$> tags c
+--     ts = toRecord <$> tags c
-    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
+--     toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
-    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+--     tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
 updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
 updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits

lib/Internal/Types/Database.hs

@@ -11,6 +11,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
 import Internal.Types.Dhall
 import RIO
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
@@ -124,16 +125,21 @@ data AcntPath = AcntPath
   }
   deriving (Eq, Ord, Show, Hashable, Generic, Read)
 
+acntPath2Text :: AcntPath -> T.Text
+acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
+
+acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
+acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
+
 instance PersistFieldSql AcntPath where
   sqlType _ = SqlString
 
 instance PersistField AcntPath where
-  toPersistValue (AcntPath t cs) =
+  toPersistValue = PersistText . acntPath2Text
-    PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs
 
   fromPersistValue (PersistText v) = case T.split (== '/') v of
     [] -> Left "path is empty"
     (x : xs) -> case readMaybe $ T.unpack x of
-      Just t -> Right $ AcntPath t $ reverse xs
+      Just t -> Right $ AcntPath t xs
       _ -> Left "could not get account type"
   fromPersistValue _ = Left "not a string"

lib/Internal/Utils.hs

@@ -29,7 +29,6 @@ module Internal.Utils
   , mapErrorsIO
   , mapErrorsPooledIO
   , showError
-  , acntPath2Text
   , tshow
   , lookupErr
   , gregorians
@@ -419,9 +418,6 @@ 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
 
-acntPath2Text :: AcntPath -> T.Text
-acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
-
 --------------------------------------------------------------------------------
 -- error display
 
@@ -618,10 +614,10 @@ groupKey f = fmap go . NE.groupAllWith (f . fst)
   where
     go xs@((c, _) :| _) = (c, fmap snd xs)
 
-groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
+groupWith :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
 groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
   where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+    go xs@((c, _) :| _) = (c, fmap snd xs)
 
 mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
 mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k