ENH generalize IO monads
This commit is contained in:
parent
20cc4db986
commit
47480d27c4
16
app/Main.hs
16
app/Main.hs
|
@ -107,15 +107,15 @@ parse (Options c DumpAccountKeys) = runDumpAccountKeys c
|
||||||
parse (Options c DumpCurrencies) = runDumpCurrencies c
|
parse (Options c DumpCurrencies) = runDumpCurrencies c
|
||||||
parse (Options c Sync) = runSync c
|
parse (Options c Sync) = runSync c
|
||||||
|
|
||||||
runDumpCurrencies :: FilePath -> IO ()
|
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runDumpCurrencies c = do
|
runDumpCurrencies c = do
|
||||||
cs <- currencies <$> readConfig c
|
cs <- currencies <$> readConfig c
|
||||||
putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
|
liftIO $ putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
|
||||||
where
|
where
|
||||||
fmt Currency {curSymbol = s, curFullname = f} =
|
fmt Currency {curSymbol = s, curFullname = f} =
|
||||||
T.concat [s, ": ", f]
|
T.concat [s, ": ", f]
|
||||||
|
|
||||||
runDumpAccounts :: FilePath -> IO ()
|
runDumpAccounts :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runDumpAccounts c = do
|
runDumpAccounts c = do
|
||||||
ar <- accounts <$> readConfig c
|
ar <- accounts <$> readConfig c
|
||||||
mapM_ (\(h, f) -> printTree h $ f ar) ps
|
mapM_ (\(h, f) -> printTree h $ f ar) ps
|
||||||
|
@ -128,7 +128,7 @@ runDumpAccounts c = do
|
||||||
, ("Liabilities", arLiabilities)
|
, ("Liabilities", arLiabilities)
|
||||||
]
|
]
|
||||||
printTree h ts = do
|
printTree h ts = do
|
||||||
putStrLn h
|
liftIO $ putStrLn h
|
||||||
mapM (go 1) ts
|
mapM (go 1) ts
|
||||||
go i (Placeholder d n cs) = do
|
go i (Placeholder d n cs) = do
|
||||||
printAcnt i d n
|
printAcnt i d n
|
||||||
|
@ -136,9 +136,9 @@ runDumpAccounts c = do
|
||||||
go i (Account d n) = printAcnt i d n
|
go i (Account d n) = printAcnt i d n
|
||||||
printAcnt i d n = do
|
printAcnt i d n = do
|
||||||
let ind = T.replicate (i * 2) " "
|
let ind = T.replicate (i * 2) " "
|
||||||
putStrLn $ T.unpack $ T.concat [ind, n, ": ", d]
|
liftIO $ putStrLn $ T.unpack $ T.concat [ind, n, ": ", d]
|
||||||
|
|
||||||
runDumpAccountKeys :: FilePath -> IO ()
|
runDumpAccountKeys :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runDumpAccountKeys c = do
|
runDumpAccountKeys c = do
|
||||||
ar <- accounts <$> readConfig c
|
ar <- accounts <$> readConfig c
|
||||||
let ks =
|
let ks =
|
||||||
|
@ -149,11 +149,11 @@ runDumpAccountKeys c = do
|
||||||
mapM_ (uncurry printPair) ks
|
mapM_ (uncurry printPair) ks
|
||||||
where
|
where
|
||||||
printPair i p = do
|
printPair i p = do
|
||||||
putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
||||||
t3 (_, _, x) = x
|
t3 (_, _, x) = x
|
||||||
double x = (x, x)
|
double x = (x, x)
|
||||||
|
|
||||||
runSync :: FilePath -> IO ()
|
runSync :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runSync c = do
|
runSync c = do
|
||||||
config <- readConfig c
|
config <- readConfig c
|
||||||
migrate_ (sqlConfig config) $ do
|
migrate_ (sqlConfig config) $ do
|
||||||
|
|
|
@ -8,10 +8,10 @@ where
|
||||||
-- import Data.Yaml
|
-- import Data.Yaml
|
||||||
import Dhall hiding (record)
|
import Dhall hiding (record)
|
||||||
import Internal.Types
|
import Internal.Types
|
||||||
|
import RIO
|
||||||
|
|
||||||
readConfig :: FilePath -> IO Config
|
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||||
readConfig confpath = do
|
readConfig confpath = liftIO $ unfix <$> inputFile auto confpath
|
||||||
unfix <$> inputFile auto confpath
|
|
||||||
|
|
||||||
-- readYaml :: FromJSON a => FilePath -> IO a
|
-- readYaml :: FromJSON a => FilePath -> IO a
|
||||||
-- readYaml p = do
|
-- readYaml p = do
|
||||||
|
|
|
@ -33,7 +33,11 @@ import qualified RIO.List as L
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
|
migrate_
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> SqlConfig
|
||||||
|
-> SqlPersistT (ResourceT (NoLoggingT m)) ()
|
||||||
|
-> m ()
|
||||||
migrate_ c more =
|
migrate_ c more =
|
||||||
runNoLoggingT $
|
runNoLoggingT $
|
||||||
runResourceT $
|
runResourceT $
|
||||||
|
@ -45,21 +49,21 @@ migrate_ c more =
|
||||||
more
|
more
|
||||||
)
|
)
|
||||||
|
|
||||||
openConnection :: SqlConfig -> LogFunc -> IO SqlBackend
|
openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
|
||||||
openConnection c logfn = case c of
|
openConnection c logfn = case c of
|
||||||
Sqlite p -> do
|
Sqlite p -> liftIO $ do
|
||||||
conn <- open p
|
conn <- open p
|
||||||
wrapConnection conn logfn
|
wrapConnection conn logfn
|
||||||
Postgres -> error "postgres not implemented"
|
Postgres -> error "postgres not implemented"
|
||||||
|
|
||||||
nukeTables :: MonadIO m => SqlPersistT m ()
|
nukeTables :: MonadUnliftIO m => SqlPersistT m ()
|
||||||
nukeTables = do
|
nukeTables = do
|
||||||
deleteWhere ([] :: [Filter CommitR])
|
deleteWhere ([] :: [Filter CommitR])
|
||||||
deleteWhere ([] :: [Filter CurrencyR])
|
deleteWhere ([] :: [Filter CurrencyR])
|
||||||
deleteWhere ([] :: [Filter AccountR])
|
deleteWhere ([] :: [Filter AccountR])
|
||||||
deleteWhere ([] :: [Filter TransactionR])
|
deleteWhere ([] :: [Filter TransactionR])
|
||||||
|
|
||||||
showBalances :: MonadIO m => SqlPersistT m ()
|
showBalances :: MonadUnliftIO m => SqlPersistT m ()
|
||||||
showBalances = do
|
showBalances = do
|
||||||
xs <- select $ do
|
xs <- select $ do
|
||||||
(accounts :& splits :& txs) <-
|
(accounts :& splits :& txs) <-
|
||||||
|
@ -121,47 +125,47 @@ setDiff as bs = (as \\ bs, bs \\ as)
|
||||||
-- | f a b = Just bs
|
-- | f a b = Just bs
|
||||||
-- | otherwise = inB a bs
|
-- | otherwise = inB a bs
|
||||||
|
|
||||||
getDBHashes :: MonadIO m => SqlPersistT m [Int]
|
getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
|
||||||
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||||
|
|
||||||
nukeDBHash :: MonadIO m => Int -> SqlPersistT m ()
|
nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
|
||||||
nukeDBHash h = delete $ do
|
nukeDBHash h = delete $ do
|
||||||
c <- from table
|
c <- from table
|
||||||
where_ (c ^. CommitRHash ==. val h)
|
where_ (c ^. CommitRHash ==. val h)
|
||||||
|
|
||||||
nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m ()
|
nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
|
||||||
nukeDBHashes = mapM_ nukeDBHash
|
nukeDBHashes = mapM_ nukeDBHash
|
||||||
|
|
||||||
getConfigHashes :: MonadIO m => Config -> SqlPersistT m ([Int], [Int])
|
getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
|
||||||
getConfigHashes c = do
|
getConfigHashes c = do
|
||||||
let ch = hashConfig c
|
let ch = hashConfig c
|
||||||
dh <- getDBHashes
|
dh <- getDBHashes
|
||||||
return $ setDiff dh ch
|
return $ setDiff dh ch
|
||||||
|
|
||||||
updateHashes :: MonadIO m => Config -> SqlPersistT m [Int]
|
updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
|
||||||
updateHashes c = do
|
updateHashes c = do
|
||||||
(del, new) <- getConfigHashes c
|
(del, new) <- getConfigHashes c
|
||||||
nukeDBHashes del
|
nukeDBHashes del
|
||||||
return new
|
return new
|
||||||
|
|
||||||
dumpTbl :: (PersistEntity r, MonadIO m) => SqlPersistT m [Entity r]
|
dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
|
||||||
dumpTbl = select $ from table
|
dumpTbl = select $ from table
|
||||||
|
|
||||||
deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m ()
|
deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
|
||||||
deleteAccount e = delete $ do
|
deleteAccount e = delete $ do
|
||||||
c <- from $ table @AccountR
|
c <- from $ table @AccountR
|
||||||
where_ (c ^. AccountRId ==. val k)
|
where_ (c ^. AccountRId ==. val k)
|
||||||
where
|
where
|
||||||
k = entityKey e
|
k = entityKey e
|
||||||
|
|
||||||
deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m ()
|
deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
|
||||||
deleteCurrency e = delete $ do
|
deleteCurrency e = delete $ do
|
||||||
c <- from $ table @CurrencyR
|
c <- from $ table @CurrencyR
|
||||||
where_ (c ^. CurrencyRId ==. val k)
|
where_ (c ^. CurrencyRId ==. val k)
|
||||||
where
|
where
|
||||||
k = entityKey e
|
k = entityKey e
|
||||||
|
|
||||||
updateAccounts :: MonadIO m => AccountRoot -> SqlPersistT m AccountMap
|
updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
|
||||||
updateAccounts ar = do
|
updateAccounts ar = do
|
||||||
let (acnts, paths, acntMap) = indexAcntRoot ar
|
let (acnts, paths, acntMap) = indexAcntRoot ar
|
||||||
acnts' <- dumpTbl
|
acnts' <- dumpTbl
|
||||||
|
@ -174,12 +178,12 @@ updateAccounts ar = do
|
||||||
return acntMap
|
return acntMap
|
||||||
|
|
||||||
insertFull
|
insertFull
|
||||||
:: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
||||||
=> Entity r
|
=> Entity r
|
||||||
-> ReaderT b m ()
|
-> ReaderT b m ()
|
||||||
insertFull (Entity k v) = insertKey k v
|
insertFull (Entity k v) = insertKey k v
|
||||||
|
|
||||||
updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap
|
updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap
|
||||||
updateCurrencies cs = do
|
updateCurrencies cs = do
|
||||||
let curs = fmap currency2Record cs
|
let curs = fmap currency2Record cs
|
||||||
curs' <- select $ from $ table @CurrencyR
|
curs' <- select $ from $ table @CurrencyR
|
||||||
|
@ -298,7 +302,7 @@ indexAcntRoot r =
|
||||||
where
|
where
|
||||||
(ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
|
(ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
|
||||||
|
|
||||||
getDBState :: MonadIO m => Config -> SqlPersistT m (FilePath -> DBState)
|
getDBState :: MonadUnliftIO m => Config -> SqlPersistT m (FilePath -> DBState)
|
||||||
getDBState c = do
|
getDBState c = do
|
||||||
am <- updateAccounts $ accounts c
|
am <- updateAccounts $ accounts c
|
||||||
cm <- updateCurrencies $ currencies c
|
cm <- updateCurrencies $ currencies c
|
||||||
|
|
|
@ -20,7 +20,7 @@ import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
|
lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v)
|
||||||
lookupKey m k = do
|
lookupKey m k = do
|
||||||
let v = M.lookup k m
|
let v = M.lookup k m
|
||||||
when (isNothing v) $
|
when (isNothing v) $
|
||||||
|
@ -29,18 +29,18 @@ lookupKey m k = do
|
||||||
"key does not exist: " ++ show k
|
"key does not exist: " ++ show k
|
||||||
return v
|
return v
|
||||||
|
|
||||||
lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
|
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
|
||||||
lookupAccount p = do
|
lookupAccount p = do
|
||||||
m <- asks kmAccount
|
m <- asks kmAccount
|
||||||
lookupKey m p
|
lookupKey m p
|
||||||
|
|
||||||
lookupAccountKey :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR))
|
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR))
|
||||||
lookupAccountKey = fmap (fmap fst) . lookupAccount
|
lookupAccountKey = fmap (fmap fst) . lookupAccount
|
||||||
|
|
||||||
lookupAccountSign :: MonadIO m => AcntID -> MappingT m (Maybe AcntSign)
|
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
|
||||||
lookupAccountSign = fmap (fmap snd) . lookupAccount
|
lookupAccountSign = fmap (fmap snd) . lookupAccount
|
||||||
|
|
||||||
lookupCurrency :: MonadIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
|
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
|
||||||
lookupCurrency c = do
|
lookupCurrency c = do
|
||||||
m <- asks kmCurrency
|
m <- asks kmCurrency
|
||||||
lookupKey m c
|
lookupKey m c
|
||||||
|
@ -121,7 +121,7 @@ mdyPatternMatches check x p = case p of
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- budget
|
-- budget
|
||||||
|
|
||||||
insertBudget :: MonadIO m => Budget -> MappingT m ()
|
insertBudget :: MonadUnliftIO m => Budget -> MappingT m ()
|
||||||
insertBudget Budget {income = is, expenses = es} = do
|
insertBudget Budget {income = is, expenses = es} = do
|
||||||
mapM_ insertIncome is
|
mapM_ insertIncome is
|
||||||
mapM_ insertExpense es
|
mapM_ insertExpense es
|
||||||
|
@ -129,7 +129,7 @@ insertBudget Budget {income = is, expenses = es} = do
|
||||||
-- TODO this hashes twice (not that it really matters)
|
-- TODO this hashes twice (not that it really matters)
|
||||||
whenHash
|
whenHash
|
||||||
:: Hashable a
|
:: Hashable a
|
||||||
=> MonadIO m
|
=> MonadUnliftIO m
|
||||||
=> ConfigType
|
=> ConfigType
|
||||||
-> a
|
-> a
|
||||||
-> (Key CommitR -> MappingT m ())
|
-> (Key CommitR -> MappingT m ())
|
||||||
|
@ -140,7 +140,7 @@ whenHash t o f = do
|
||||||
when (h `elem` hs) $ do
|
when (h `elem` hs) $ do
|
||||||
f =<< lift (insert $ CommitR h t)
|
f =<< lift (insert $ CommitR h t)
|
||||||
|
|
||||||
insertIncome :: MonadIO m => Income -> MappingT m ()
|
insertIncome :: MonadUnliftIO m => Income -> MappingT m ()
|
||||||
insertIncome
|
insertIncome
|
||||||
i@Income
|
i@Income
|
||||||
{ incCurrency = cur
|
{ incCurrency = cur
|
||||||
|
@ -204,7 +204,7 @@ mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
|
||||||
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
|
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
|
||||||
|
|
||||||
allocationToTx
|
allocationToTx
|
||||||
:: MonadIO m
|
:: MonadUnliftIO m
|
||||||
=> AcntID
|
=> AcntID
|
||||||
-> Day
|
-> Day
|
||||||
-> BalAllocation
|
-> BalAllocation
|
||||||
|
@ -220,12 +220,12 @@ allocationToTx
|
||||||
} =
|
} =
|
||||||
fmap (,b) <$> mapM (transferToTx day from to cur) as
|
fmap (,b) <$> mapM (transferToTx day from to cur) as
|
||||||
|
|
||||||
taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
|
taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
|
||||||
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
|
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
|
||||||
txPair day from to cur (dec2Rat v) ""
|
txPair day from to cur (dec2Rat v) ""
|
||||||
|
|
||||||
transferToTx
|
transferToTx
|
||||||
:: MonadIO m
|
:: MonadUnliftIO m
|
||||||
=> Day
|
=> Day
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> AcntID
|
-> AcntID
|
||||||
|
@ -235,7 +235,7 @@ transferToTx
|
||||||
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
||||||
txPair day from to cur v d
|
txPair day from to cur v d
|
||||||
|
|
||||||
insertExpense :: MonadIO m => Expense -> MappingT m ()
|
insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
|
||||||
insertExpense
|
insertExpense
|
||||||
e@Expense
|
e@Expense
|
||||||
{ expFrom = from
|
{ expFrom = from
|
||||||
|
@ -249,7 +249,7 @@ insertExpense
|
||||||
lift $ mapM_ (insertTxBucket (Just buc) c) ts
|
lift $ mapM_ (insertTxBucket (Just buc) c) ts
|
||||||
|
|
||||||
timeAmountToTx
|
timeAmountToTx
|
||||||
:: MonadIO m
|
:: MonadUnliftIO m
|
||||||
=> AcntID
|
=> AcntID
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> T.Text
|
-> T.Text
|
||||||
|
@ -275,14 +275,14 @@ timeAmountToTx
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- statements
|
-- statements
|
||||||
|
|
||||||
insertStatements :: MonadIO m => Config -> MappingT m ()
|
insertStatements :: MonadUnliftIO m => Config -> MappingT m ()
|
||||||
insertStatements = mapM_ insertStatement . statements
|
insertStatements = mapM_ insertStatement . statements
|
||||||
|
|
||||||
insertStatement :: MonadIO m => Statement -> MappingT m ()
|
insertStatement :: MonadUnliftIO m => Statement -> MappingT m ()
|
||||||
insertStatement (StmtManual m) = insertManual m
|
insertStatement (StmtManual m) = insertManual m
|
||||||
insertStatement (StmtImport i) = insertImport i
|
insertStatement (StmtImport i) = insertImport i
|
||||||
|
|
||||||
insertManual :: MonadIO m => Manual -> MappingT m ()
|
insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
|
||||||
insertManual
|
insertManual
|
||||||
m@Manual
|
m@Manual
|
||||||
{ manualDate = dp
|
{ manualDate = dp
|
||||||
|
@ -299,7 +299,7 @@ insertManual
|
||||||
where
|
where
|
||||||
tx day = txPair day from to u (dec2Rat v) e
|
tx day = txPair day from to u (dec2Rat v) e
|
||||||
|
|
||||||
insertImport :: MonadIO m => Import -> MappingT m ()
|
insertImport :: MonadUnliftIO m => Import -> MappingT m ()
|
||||||
insertImport i = whenHash CTImport i $ \c -> do
|
insertImport i = whenHash CTImport i $ \c -> do
|
||||||
bounds <- asks kmStatementInterval
|
bounds <- asks kmStatementInterval
|
||||||
bs <- readImport i
|
bs <- readImport i
|
||||||
|
@ -312,7 +312,7 @@ insertImport i = whenHash CTImport i $ \c -> do
|
||||||
-- low-level transaction stuff
|
-- low-level transaction stuff
|
||||||
|
|
||||||
txPair
|
txPair
|
||||||
:: MonadIO m
|
:: MonadUnliftIO m
|
||||||
=> Day
|
=> Day
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> AcntID
|
-> AcntID
|
||||||
|
@ -331,12 +331,12 @@ txPair day from to cur val desc = resolveTx tx
|
||||||
, txSplits = [split from (-val), split to val]
|
, txSplits = [split from (-val), split to val]
|
||||||
}
|
}
|
||||||
|
|
||||||
resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx
|
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx
|
||||||
resolveTx t@Tx {txSplits = ss} = do
|
resolveTx t@Tx {txSplits = ss} = do
|
||||||
rs <- catMaybes <$> mapM resolveSplit ss
|
rs <- catMaybes <$> mapM resolveSplit ss
|
||||||
return $ t {txSplits = rs}
|
return $ t {txSplits = rs}
|
||||||
|
|
||||||
resolveSplit :: MonadIO m => BalSplit -> MappingT m (Maybe KeySplit)
|
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit)
|
||||||
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
||||||
aid <- lookupAccountKey p
|
aid <- lookupAccountKey p
|
||||||
cid <- lookupCurrency c
|
cid <- lookupCurrency c
|
||||||
|
@ -353,14 +353,14 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
||||||
}
|
}
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
insertTxBucket :: MonadIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
|
insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||||
k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
|
k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
|
||||||
mapM_ (insertSplit k) ss
|
mapM_ (insertSplit k) ss
|
||||||
|
|
||||||
insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
insertTx = insertTxBucket Nothing
|
insertTx = insertTxBucket Nothing
|
||||||
|
|
||||||
insertSplit :: MonadIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
|
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
|
||||||
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
||||||
insert_ $ SplitR t cid aid c v
|
insert_ $ SplitR t cid aid c v
|
||||||
|
|
|
@ -3,9 +3,10 @@
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
module Internal.Statement (
|
module Internal.Statement
|
||||||
readImport,
|
( readImport
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Csv
|
import Data.Csv
|
||||||
import Internal.Database.Model
|
import Internal.Database.Model
|
||||||
|
@ -22,84 +23,84 @@ import qualified RIO.Vector as V
|
||||||
|
|
||||||
-- TODO this probably won't scale well (pipes?)
|
-- TODO this probably won't scale well (pipes?)
|
||||||
|
|
||||||
readImport :: MonadIO m => Import -> MappingT m [BalTx]
|
readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx]
|
||||||
readImport
|
readImport
|
||||||
Import
|
Import
|
||||||
{ impPaths = ps
|
{ impPaths = ps
|
||||||
, impMatches = ms
|
, impMatches = ms
|
||||||
, impTxOpts = ns
|
, impTxOpts = ns
|
||||||
, impDelim = d
|
, impDelim = d
|
||||||
, impSkipLines = n
|
, impSkipLines = n
|
||||||
} = do
|
} = do
|
||||||
rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps
|
rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps
|
||||||
let (ts, es, notfound) = matchRecords ms rs
|
let (ts, es, notfound) = matchRecords ms rs
|
||||||
liftIO $ mapM_ putStrLn $ reverse es
|
liftIO $ mapM_ putStrLn $ reverse es
|
||||||
liftIO $ mapM_ print notfound
|
liftIO $ mapM_ print notfound
|
||||||
return ts
|
return ts
|
||||||
|
|
||||||
readImport_ ::
|
readImport_
|
||||||
MonadIO m =>
|
:: MonadUnliftIO m
|
||||||
Natural ->
|
=> Natural
|
||||||
Word ->
|
-> Word
|
||||||
TxOpts ->
|
-> TxOpts
|
||||||
FilePath ->
|
-> FilePath
|
||||||
MappingT m [TxRecord]
|
-> MappingT m [TxRecord]
|
||||||
readImport_ n delim tns p = do
|
readImport_ n delim tns p = do
|
||||||
dir <- asks kmConfigDir
|
dir <- asks kmConfigDir
|
||||||
bs <- liftIO $ BL.readFile $ dir </> p
|
bs <- liftIO $ BL.readFile $ dir </> p
|
||||||
case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of
|
case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of
|
||||||
Left m -> liftIO $ putStrLn m >> return []
|
Left m -> liftIO $ putStrLn m >> return []
|
||||||
Right (_, v) -> return $ catMaybes $ V.toList v
|
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||||
where
|
where
|
||||||
opts = defaultDecodeOptions{decDelimiter = fromIntegral delim}
|
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
||||||
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
|
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
|
||||||
|
|
||||||
-- TODO handle this better, this maybe thing is a hack to skip lines with
|
-- 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
|
-- blank dates but will likely want to make this more flexible
|
||||||
parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
|
parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
|
||||||
parseTxRecord TxOpts{..} r = do
|
parseTxRecord TxOpts {..} r = do
|
||||||
d <- r .: T.encodeUtf8 toDate
|
d <- r .: T.encodeUtf8 toDate
|
||||||
if d == ""
|
if d == ""
|
||||||
then return Nothing
|
then return Nothing
|
||||||
else do
|
else do
|
||||||
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||||
e <- r .: T.encodeUtf8 toDesc
|
e <- r .: T.encodeUtf8 toDesc
|
||||||
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||||
return $ Just $ TxRecord d' a e os
|
return $ Just $ TxRecord d' a e os
|
||||||
|
|
||||||
matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
|
matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
|
||||||
matchRecords ms rs =
|
matchRecords ms rs =
|
||||||
( catMaybes ts
|
( catMaybes ts
|
||||||
, T.unpack <$> (es ++ bu)
|
, T.unpack <$> (es ++ bu)
|
||||||
, -- TODO record number of times each match hits for debugging
|
, -- TODO record number of times each match hits for debugging
|
||||||
notfound
|
notfound
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
(matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
|
(matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
|
||||||
(es, ts) =
|
(es, ts) =
|
||||||
partitionEithers $
|
partitionEithers $
|
||||||
fmap Just . balanceTx <$> catMaybes matched
|
fmap Just . balanceTx <$> catMaybes matched
|
||||||
bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
|
bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
|
||||||
|
|
||||||
matchPriorities :: [Match] -> [MatchGroup]
|
matchPriorities :: [Match] -> [MatchGroup]
|
||||||
matchPriorities =
|
matchPriorities =
|
||||||
fmap matchToGroup
|
fmap matchToGroup
|
||||||
. L.groupBy (\a b -> mPriority a == mPriority b)
|
. L.groupBy (\a b -> mPriority a == mPriority b)
|
||||||
. L.sortOn (Down . mPriority)
|
. L.sortOn (Down . mPriority)
|
||||||
|
|
||||||
matchToGroup :: [Match] -> MatchGroup
|
matchToGroup :: [Match] -> MatchGroup
|
||||||
matchToGroup ms =
|
matchToGroup ms =
|
||||||
uncurry MatchGroup $
|
uncurry MatchGroup $
|
||||||
first (L.sortOn mDate) $
|
first (L.sortOn mDate) $
|
||||||
L.partition (isJust . mDate) ms
|
L.partition (isJust . mDate) ms
|
||||||
|
|
||||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
-- TDOO could use a better struct to flatten the maybe date subtype
|
||||||
data MatchGroup = MatchGroup
|
data MatchGroup = MatchGroup
|
||||||
{ mgDate :: [Match]
|
{ mgDate :: [Match]
|
||||||
, mgNoDate :: [Match]
|
, mgNoDate :: [Match]
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data Zipped a = Zipped ![a] ![a]
|
data Zipped a = Zipped ![a] ![a]
|
||||||
|
|
||||||
|
@ -119,37 +120,37 @@ zipperSlice f x = go
|
||||||
where
|
where
|
||||||
go z@(Zipped _ []) = Left z
|
go z@(Zipped _ []) = Left z
|
||||||
go z@(Zipped bs (a : as)) = case f a x of
|
go z@(Zipped bs (a : as)) = case f a x of
|
||||||
GT -> go $ Zipped (a : bs) as
|
GT -> go $ Zipped (a : bs) as
|
||||||
EQ -> Right $ goEq (Unzipped bs [a] as)
|
EQ -> Right $ goEq (Unzipped bs [a] as)
|
||||||
LT -> Left z
|
LT -> Left z
|
||||||
goEq z@(Unzipped _ _ []) = z
|
goEq z@(Unzipped _ _ []) = z
|
||||||
goEq z@(Unzipped bs cs (a : as)) = case f a x of
|
goEq z@(Unzipped bs cs (a : as)) = case f a x of
|
||||||
GT -> goEq $ Unzipped (a : bs) cs as
|
GT -> goEq $ Unzipped (a : bs) cs as
|
||||||
EQ -> goEq $ Unzipped bs (a : cs) as
|
EQ -> goEq $ Unzipped bs (a : cs) as
|
||||||
LT -> z
|
LT -> z
|
||||||
|
|
||||||
zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
|
zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
|
||||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
where
|
where
|
||||||
go _ [] = (Zipped bs $ cs ++ as, Nothing)
|
go _ [] = (Zipped bs $ cs ++ as, Nothing)
|
||||||
go prev (m : ms) = case matches m x of
|
go prev (m : ms) = case matches m x of
|
||||||
Nothing -> go (m : prev) ms
|
Nothing -> go (m : prev) ms
|
||||||
res@(Just _) ->
|
res@(Just _) ->
|
||||||
let ps = reverse prev
|
let ps = reverse prev
|
||||||
ms' = maybe ms (: ms) (matchDec m)
|
ms' = maybe ms (: ms) (matchDec m)
|
||||||
in (Zipped bs $ ps ++ ms' ++ as, res)
|
in (Zipped bs $ ps ++ ms' ++ as, res)
|
||||||
|
|
||||||
zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
|
zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
|
||||||
zipperMatch' z x = go z
|
zipperMatch' z x = go z
|
||||||
where
|
where
|
||||||
go (Zipped bs (a : as)) = case matches a x of
|
go (Zipped bs (a : as)) = case matches a x of
|
||||||
Nothing -> go (Zipped (a : bs) as)
|
Nothing -> go (Zipped (a : bs) as)
|
||||||
res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res)
|
res -> (Zipped (maybe bs (: bs) $ matchDec a) as, res)
|
||||||
go z' = (z', Nothing)
|
go z' = (z', Nothing)
|
||||||
|
|
||||||
matchDec :: Match -> Maybe Match
|
matchDec :: Match -> Maybe Match
|
||||||
matchDec m@Match{mTimes = t} =
|
matchDec m@Match {mTimes = t} =
|
||||||
if t' == Just 0 then Nothing else Just $ m{mTimes = t'}
|
if t' == Just 0 then Nothing else Just $ m {mTimes = t'}
|
||||||
where
|
where
|
||||||
t' = fmap pred t
|
t' = fmap pred t
|
||||||
|
|
||||||
|
@ -157,15 +158,15 @@ matchAll :: [MatchGroup] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||||
matchAll = go ([], [])
|
matchAll = go ([], [])
|
||||||
where
|
where
|
||||||
go (matched, unused) gs rs = case (gs, rs) of
|
go (matched, unused) gs rs = case (gs, rs) of
|
||||||
(_, []) -> (matched, [], unused)
|
(_, []) -> (matched, [], unused)
|
||||||
([], _) -> (matched, rs, unused)
|
([], _) -> (matched, rs, unused)
|
||||||
(g : gs', _) ->
|
(g : gs', _) ->
|
||||||
let (ts, unmatched, us) = matchGroup g rs
|
let (ts, unmatched, us) = matchGroup g rs
|
||||||
in go (ts ++ matched, us ++ unused) gs' unmatched
|
in go (ts ++ matched, us ++ unused) gs' unmatched
|
||||||
|
|
||||||
matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||||
matchGroup MatchGroup{mgDate = ds, mgNoDate = ns} rs =
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs =
|
||||||
(md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
(md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
|
||||||
where
|
where
|
||||||
(md, rest, ud) = matchDates ds rs
|
(md, rest, ud) = matchDates ds rs
|
||||||
(mn, unmatched, un) = matchNonDates ns rest
|
(mn, unmatched, un) = matchNonDates ns rest
|
||||||
|
@ -175,13 +176,13 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
|
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
|
||||||
go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
|
go (matched, unmatched, z) (r : rs) = case zipperSlice findDate r z of
|
||||||
Left res -> go (matched, r : unmatched, res) rs
|
Left res -> go (matched, r : unmatched, res) rs
|
||||||
Right res ->
|
Right res ->
|
||||||
let (z', p) = zipperMatch res r
|
let (z', p) = zipperMatch res r
|
||||||
(m, u) = case p of
|
(m, u) = case p of
|
||||||
Just p' -> (p' : matched, unmatched)
|
Just p' -> (p' : matched, unmatched)
|
||||||
Nothing -> (matched, r : unmatched)
|
Nothing -> (matched, r : unmatched)
|
||||||
in go (m, u, z') rs
|
in go (m, u, z') rs
|
||||||
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
|
findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
|
||||||
|
|
||||||
matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
|
||||||
|
@ -189,32 +190,32 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
|
go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z)
|
||||||
go (matched, unmatched, z) (r : rs) =
|
go (matched, unmatched, z) (r : rs) =
|
||||||
let (z', res) = zipperMatch' z r
|
let (z', res) = zipperMatch' z r
|
||||||
(m, u) = case res of
|
(m, u) = case res of
|
||||||
Just x -> (x : matched, unmatched)
|
Just x -> (x : matched, unmatched)
|
||||||
Nothing -> (matched, r : unmatched)
|
Nothing -> (matched, r : unmatched)
|
||||||
in go (m, u, resetZipper z') rs
|
in go (m, u, resetZipper z') rs
|
||||||
|
|
||||||
balanceTx :: RawTx -> Either T.Text BalTx
|
balanceTx :: RawTx -> Either T.Text BalTx
|
||||||
balanceTx t@Tx{txSplits = ss} = do
|
balanceTx t@Tx {txSplits = ss} = do
|
||||||
bs <- balanceSplits ss
|
bs <- balanceSplits ss
|
||||||
return $ t{txSplits = bs}
|
return $ t {txSplits = bs}
|
||||||
|
|
||||||
balanceSplits :: [RawSplit] -> Either T.Text [BalSplit]
|
balanceSplits :: [RawSplit] -> Either T.Text [BalSplit]
|
||||||
balanceSplits ss =
|
balanceSplits ss =
|
||||||
fmap concat
|
fmap concat
|
||||||
<$> mapM (uncurry bal)
|
<$> mapM (uncurry bal)
|
||||||
$ groupByKey
|
$ groupByKey
|
||||||
$ fmap (\s -> (sCurrency s, s)) ss
|
$ fmap (\s -> (sCurrency s, s)) ss
|
||||||
where
|
where
|
||||||
hasValue s@(Split{sValue = Just v}) = Right s{sValue = v}
|
hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
|
||||||
hasValue s = Left s
|
hasValue s = Left s
|
||||||
bal cur rss
|
bal cur rss
|
||||||
| length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur
|
| length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur
|
||||||
| otherwise = case partitionEithers $ fmap hasValue rss of
|
| otherwise = case partitionEithers $ fmap hasValue rss of
|
||||||
([noVal], val) -> Right $ noVal{sValue = foldr (\s x -> x - sValue s) 0 val} : val
|
([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
|
||||||
([], val) -> Right val
|
([], val) -> Right val
|
||||||
_ -> Left $ T.append "Exactly one split must be blank: " cur
|
_ -> Left $ T.append "Exactly one split must be blank: " cur
|
||||||
|
|
||||||
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
||||||
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
||||||
|
|
|
@ -227,7 +227,7 @@ intervalMaybeBounds :: Interval -> MaybeBounds
|
||||||
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
|
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
|
||||||
(fromGregorian' <$> s, fromGregorian' <$> e)
|
(fromGregorian' <$> s, fromGregorian' <$> e)
|
||||||
|
|
||||||
resolveBounds :: MaybeBounds -> IO Bounds
|
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
||||||
resolveBounds (s, e) = do
|
resolveBounds (s, e) = do
|
||||||
s' <- maybe getDay return s
|
s' <- maybe getDay return s
|
||||||
e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
|
e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
|
||||||
|
|
Loading…
Reference in New Issue