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 Sync) = runSync c
|
||||
|
||||
runDumpCurrencies :: FilePath -> IO ()
|
||||
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
|
||||
runDumpCurrencies c = do
|
||||
cs <- currencies <$> readConfig c
|
||||
putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
|
||||
liftIO $ putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
|
||||
where
|
||||
fmt Currency {curSymbol = s, curFullname = f} =
|
||||
T.concat [s, ": ", f]
|
||||
|
||||
runDumpAccounts :: FilePath -> IO ()
|
||||
runDumpAccounts :: MonadUnliftIO m => FilePath -> m ()
|
||||
runDumpAccounts c = do
|
||||
ar <- accounts <$> readConfig c
|
||||
mapM_ (\(h, f) -> printTree h $ f ar) ps
|
||||
|
|
@ -128,7 +128,7 @@ runDumpAccounts c = do
|
|||
, ("Liabilities", arLiabilities)
|
||||
]
|
||||
printTree h ts = do
|
||||
putStrLn h
|
||||
liftIO $ putStrLn h
|
||||
mapM (go 1) ts
|
||||
go i (Placeholder d n cs) = do
|
||||
printAcnt i d n
|
||||
|
|
@ -136,9 +136,9 @@ runDumpAccounts c = do
|
|||
go i (Account d n) = printAcnt i d n
|
||||
printAcnt i d n = do
|
||||
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
|
||||
ar <- accounts <$> readConfig c
|
||||
let ks =
|
||||
|
|
@ -149,11 +149,11 @@ runDumpAccountKeys c = do
|
|||
mapM_ (uncurry printPair) ks
|
||||
where
|
||||
printPair i p = do
|
||||
putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
||||
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
||||
t3 (_, _, x) = x
|
||||
double x = (x, x)
|
||||
|
||||
runSync :: FilePath -> IO ()
|
||||
runSync :: MonadUnliftIO m => FilePath -> m ()
|
||||
runSync c = do
|
||||
config <- readConfig c
|
||||
migrate_ (sqlConfig config) $ do
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ where
|
|||
-- import Data.Yaml
|
||||
import Dhall hiding (record)
|
||||
import Internal.Types
|
||||
import RIO
|
||||
|
||||
readConfig :: FilePath -> IO Config
|
||||
readConfig confpath = do
|
||||
unfix <$> inputFile auto confpath
|
||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||
readConfig confpath = liftIO $ unfix <$> inputFile auto confpath
|
||||
|
||||
-- readYaml :: FromJSON a => FilePath -> IO a
|
||||
-- readYaml p = do
|
||||
|
|
|
|||
|
|
@ -33,7 +33,11 @@ import qualified RIO.List as L
|
|||
import qualified RIO.Map as M
|
||||
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 =
|
||||
runNoLoggingT $
|
||||
runResourceT $
|
||||
|
|
@ -45,21 +49,21 @@ migrate_ c more =
|
|||
more
|
||||
)
|
||||
|
||||
openConnection :: SqlConfig -> LogFunc -> IO SqlBackend
|
||||
openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
|
||||
openConnection c logfn = case c of
|
||||
Sqlite p -> do
|
||||
Sqlite p -> liftIO $ do
|
||||
conn <- open p
|
||||
wrapConnection conn logfn
|
||||
Postgres -> error "postgres not implemented"
|
||||
|
||||
nukeTables :: MonadIO m => SqlPersistT m ()
|
||||
nukeTables :: MonadUnliftIO m => SqlPersistT m ()
|
||||
nukeTables = do
|
||||
deleteWhere ([] :: [Filter CommitR])
|
||||
deleteWhere ([] :: [Filter CurrencyR])
|
||||
deleteWhere ([] :: [Filter AccountR])
|
||||
deleteWhere ([] :: [Filter TransactionR])
|
||||
|
||||
showBalances :: MonadIO m => SqlPersistT m ()
|
||||
showBalances :: MonadUnliftIO m => SqlPersistT m ()
|
||||
showBalances = do
|
||||
xs <- select $ do
|
||||
(accounts :& splits :& txs) <-
|
||||
|
|
@ -121,47 +125,47 @@ setDiff as bs = (as \\ bs, bs \\ as)
|
|||
-- | f a b = Just bs
|
||||
-- | otherwise = inB a bs
|
||||
|
||||
getDBHashes :: MonadIO m => SqlPersistT m [Int]
|
||||
getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
|
||||
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||
|
||||
nukeDBHash :: MonadIO m => Int -> SqlPersistT m ()
|
||||
nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
|
||||
nukeDBHash h = delete $ do
|
||||
c <- from table
|
||||
where_ (c ^. CommitRHash ==. val h)
|
||||
|
||||
nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m ()
|
||||
nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
|
||||
nukeDBHashes = mapM_ nukeDBHash
|
||||
|
||||
getConfigHashes :: MonadIO m => Config -> SqlPersistT m ([Int], [Int])
|
||||
getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
|
||||
getConfigHashes c = do
|
||||
let ch = hashConfig c
|
||||
dh <- getDBHashes
|
||||
return $ setDiff dh ch
|
||||
|
||||
updateHashes :: MonadIO m => Config -> SqlPersistT m [Int]
|
||||
updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
|
||||
updateHashes c = do
|
||||
(del, new) <- getConfigHashes c
|
||||
nukeDBHashes del
|
||||
return new
|
||||
|
||||
dumpTbl :: (PersistEntity r, MonadIO m) => SqlPersistT m [Entity r]
|
||||
dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
|
||||
dumpTbl = select $ from table
|
||||
|
||||
deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m ()
|
||||
deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
|
||||
deleteAccount e = delete $ do
|
||||
c <- from $ table @AccountR
|
||||
where_ (c ^. AccountRId ==. val k)
|
||||
where
|
||||
k = entityKey e
|
||||
|
||||
deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m ()
|
||||
deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
|
||||
deleteCurrency e = delete $ do
|
||||
c <- from $ table @CurrencyR
|
||||
where_ (c ^. CurrencyRId ==. val k)
|
||||
where
|
||||
k = entityKey e
|
||||
|
||||
updateAccounts :: MonadIO m => AccountRoot -> SqlPersistT m AccountMap
|
||||
updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
|
||||
updateAccounts ar = do
|
||||
let (acnts, paths, acntMap) = indexAcntRoot ar
|
||||
acnts' <- dumpTbl
|
||||
|
|
@ -174,12 +178,12 @@ updateAccounts ar = do
|
|||
return acntMap
|
||||
|
||||
insertFull
|
||||
:: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
||||
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
||||
=> Entity r
|
||||
-> ReaderT b m ()
|
||||
insertFull (Entity k v) = insertKey k v
|
||||
|
||||
updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap
|
||||
updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap
|
||||
updateCurrencies cs = do
|
||||
let curs = fmap currency2Record cs
|
||||
curs' <- select $ from $ table @CurrencyR
|
||||
|
|
@ -298,7 +302,7 @@ indexAcntRoot r =
|
|||
where
|
||||
(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
|
||||
am <- updateAccounts $ accounts c
|
||||
cm <- updateCurrencies $ currencies c
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ import qualified RIO.Map as M
|
|||
import qualified RIO.Text as T
|
||||
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
|
||||
let v = M.lookup k m
|
||||
when (isNothing v) $
|
||||
|
|
@ -29,18 +29,18 @@ lookupKey m k = do
|
|||
"key does not exist: " ++ show k
|
||||
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
|
||||
m <- asks kmAccount
|
||||
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
|
||||
|
||||
lookupAccountSign :: MonadIO m => AcntID -> MappingT m (Maybe AcntSign)
|
||||
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
|
||||
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
|
||||
m <- asks kmCurrency
|
||||
lookupKey m c
|
||||
|
|
@ -121,7 +121,7 @@ mdyPatternMatches check x p = case p of
|
|||
--------------------------------------------------------------------------------
|
||||
-- budget
|
||||
|
||||
insertBudget :: MonadIO m => Budget -> MappingT m ()
|
||||
insertBudget :: MonadUnliftIO m => Budget -> MappingT m ()
|
||||
insertBudget Budget {income = is, expenses = es} = do
|
||||
mapM_ insertIncome is
|
||||
mapM_ insertExpense es
|
||||
|
|
@ -129,7 +129,7 @@ insertBudget Budget {income = is, expenses = es} = do
|
|||
-- TODO this hashes twice (not that it really matters)
|
||||
whenHash
|
||||
:: Hashable a
|
||||
=> MonadIO m
|
||||
=> MonadUnliftIO m
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> (Key CommitR -> MappingT m ())
|
||||
|
|
@ -140,7 +140,7 @@ whenHash t o f = do
|
|||
when (h `elem` hs) $ do
|
||||
f =<< lift (insert $ CommitR h t)
|
||||
|
||||
insertIncome :: MonadIO m => Income -> MappingT m ()
|
||||
insertIncome :: MonadUnliftIO m => Income -> MappingT m ()
|
||||
insertIncome
|
||||
i@Income
|
||||
{ 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}
|
||||
|
||||
allocationToTx
|
||||
:: MonadIO m
|
||||
:: MonadUnliftIO m
|
||||
=> AcntID
|
||||
-> Day
|
||||
-> BalAllocation
|
||||
|
|
@ -220,12 +220,12 @@ allocationToTx
|
|||
} =
|
||||
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} =
|
||||
txPair day from to cur (dec2Rat v) ""
|
||||
|
||||
transferToTx
|
||||
:: MonadIO m
|
||||
:: MonadUnliftIO m
|
||||
=> Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
|
|
@ -235,7 +235,7 @@ transferToTx
|
|||
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
||||
txPair day from to cur v d
|
||||
|
||||
insertExpense :: MonadIO m => Expense -> MappingT m ()
|
||||
insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
|
||||
insertExpense
|
||||
e@Expense
|
||||
{ expFrom = from
|
||||
|
|
@ -249,7 +249,7 @@ insertExpense
|
|||
lift $ mapM_ (insertTxBucket (Just buc) c) ts
|
||||
|
||||
timeAmountToTx
|
||||
:: MonadIO m
|
||||
:: MonadUnliftIO m
|
||||
=> AcntID
|
||||
-> AcntID
|
||||
-> T.Text
|
||||
|
|
@ -275,14 +275,14 @@ timeAmountToTx
|
|||
--------------------------------------------------------------------------------
|
||||
-- statements
|
||||
|
||||
insertStatements :: MonadIO m => Config -> MappingT m ()
|
||||
insertStatements :: MonadUnliftIO m => Config -> MappingT m ()
|
||||
insertStatements = mapM_ insertStatement . statements
|
||||
|
||||
insertStatement :: MonadIO m => Statement -> MappingT m ()
|
||||
insertStatement :: MonadUnliftIO m => Statement -> MappingT m ()
|
||||
insertStatement (StmtManual m) = insertManual m
|
||||
insertStatement (StmtImport i) = insertImport i
|
||||
|
||||
insertManual :: MonadIO m => Manual -> MappingT m ()
|
||||
insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
|
||||
insertManual
|
||||
m@Manual
|
||||
{ manualDate = dp
|
||||
|
|
@ -299,7 +299,7 @@ insertManual
|
|||
where
|
||||
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
|
||||
bounds <- asks kmStatementInterval
|
||||
bs <- readImport i
|
||||
|
|
@ -312,7 +312,7 @@ insertImport i = whenHash CTImport i $ \c -> do
|
|||
-- low-level transaction stuff
|
||||
|
||||
txPair
|
||||
:: MonadIO m
|
||||
:: MonadUnliftIO m
|
||||
=> Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
|
|
@ -331,12 +331,12 @@ txPair day from to cur val desc = resolveTx tx
|
|||
, 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
|
||||
rs <- catMaybes <$> mapM resolveSplit ss
|
||||
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
|
||||
aid <- lookupAccountKey p
|
||||
cid <- lookupCurrency c
|
||||
|
|
@ -353,14 +353,14 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
|||
}
|
||||
_ -> 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
|
||||
k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
|
||||
mapM_ (insertSplit k) ss
|
||||
|
||||
insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||
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
|
||||
insert_ $ SplitR t cid aid c v
|
||||
|
|
|
|||
|
|
@ -3,9 +3,10 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Internal.Statement (
|
||||
readImport,
|
||||
) where
|
||||
module Internal.Statement
|
||||
( readImport
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Csv
|
||||
import Internal.Database.Model
|
||||
|
|
@ -22,7 +23,7 @@ import qualified RIO.Vector as V
|
|||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
|
||||
readImport :: MonadIO m => Import -> MappingT m [BalTx]
|
||||
readImport :: MonadUnliftIO m => Import -> MappingT m [BalTx]
|
||||
readImport
|
||||
Import
|
||||
{ impPaths = ps
|
||||
|
|
@ -37,13 +38,13 @@ readImport
|
|||
liftIO $ mapM_ print notfound
|
||||
return ts
|
||||
|
||||
readImport_ ::
|
||||
MonadIO m =>
|
||||
Natural ->
|
||||
Word ->
|
||||
TxOpts ->
|
||||
FilePath ->
|
||||
MappingT m [TxRecord]
|
||||
readImport_
|
||||
:: MonadUnliftIO m
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOpts
|
||||
-> FilePath
|
||||
-> MappingT m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
dir <- asks kmConfigDir
|
||||
bs <- liftIO $ BL.readFile $ dir </> p
|
||||
|
|
|
|||
|
|
@ -227,7 +227,7 @@ intervalMaybeBounds :: Interval -> MaybeBounds
|
|||
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
|
||||
(fromGregorian' <$> s, fromGregorian' <$> e)
|
||||
|
||||
resolveBounds :: MaybeBounds -> IO Bounds
|
||||
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
||||
resolveBounds (s, e) = do
|
||||
s' <- maybe getDay return s
|
||||
e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
|
||||
|
|
|
|||
Loading…
Reference in New Issue