ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH generalize IO monads

This commit is contained in:
Nathan Dwarshuis 2023-01-05 22:23:22 -05:00
parent 20cc4db986
commit 47480d27c4
6 changed files with 160 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
app/Main.hs
View File

@ -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

6
lib/Internal/Config.hs
View File

@ -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

38
lib/Internal/Database/Ops.hs
View File

@ -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

46
lib/Internal/Insert.hs
View File

@ -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

207
lib/Internal/Statement.hs
View File

@ -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 (: []))

2
lib/Internal/Utils.hs
View File

@ -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